factor.red 285 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407
  1. % ***********************************************
  2. % ******* The REDUCE Factorization module *******
  3. % ******* A. C. Norman and P. M. A. Moore *******
  4. % ***********************************************;
  5. % This version dated 12 September 1982. ACN;
  6. % This file should be used with a system dependent file containing
  7. % a setting of the variable LARGEST!-SMALL!-MODULUS.
  8. % If at all possible the integer arithmetic
  9. % operations used here should be mapped onto corresponding ones
  10. % available in the underlying Lisp implementation, and the support
  11. % for modular arithmetic (perhaps based on these integer arithmetic
  12. % operations) should be reviewed. This file provides placeholder
  13. % definitions of functions that are used on some implementations
  14. % to support block compilation, car/cdr access checks and the like.
  15. % The front-end files on the systems that can use these features will
  16. % disable the definitions given here by use of a 'LOSE flag;;
  17. SYMBOLIC;
  18. % MODULE FSUPPORT; % Support for factorizer;
  19. DEFLIST('((MINUS!-ONE -1)),'NEWNAM); %so that it EVALs properly;
  20. SYMBOLIC SMACRO PROCEDURE CARCHECK U; NIL;
  21. FLUID '(!*TRFAC FACTOR!-LEVEL FACTOR!-TRACE!-LIST);
  22. SYMBOLIC SMACRO PROCEDURE FACTOR!-TRACE ACTION;
  23. BEGIN SCALAR STREAM;
  24. IF !*TRFAC AND FACTOR!-LEVEL = 1 THEN
  25. STREAM := NIL . NIL
  26. ELSE
  27. STREAM := ASSOC(FACTOR!-LEVEL,FACTOR!-TRACE!-LIST);
  28. IF STREAM THEN <<
  29. STREAM:=WRS CDR STREAM;
  30. ACTION;
  31. WRS STREAM >>
  32. END;
  33. SYMBOLIC SMACRO PROCEDURE GCD(M,N); GCDN(M,N);
  34. SYMBOLIC SMACRO PROCEDURE ILOGAND(M,N); LOGAND2(M,N);
  35. SYMBOLIC SMACRO PROCEDURE ILOGOR(M,N); LOGOR2(M,N);
  36. SYMBOLIC SMACRO PROCEDURE ILOGXOR(M,N); LOGXOR2(M,N);
  37. SYMBOLIC MACRO PROCEDURE LOGAND U; EXPAND(CDR U,'LOGAND2);
  38. SYMBOLIC MACRO PROCEDURE LOGOR U; EXPAND(CDR U,'LOGOR2);
  39. SYMBOLIC MACRO PROCEDURE LOGXOR U; EXPAND(CDR U,'LOGXOR2);
  40. SYMBOLIC SMACRO PROCEDURE IMIN(U,V); MIN(U,V);
  41. SYMBOLIC SMACRO PROCEDURE IRECIP U; 1/U;
  42. SYMBOLIC SMACRO PROCEDURE IRIGHTSHIFT(U,N); LEFTSHIFT(U,-N);
  43. SYMBOLIC SMACRO PROCEDURE ISDOMAIN U; DOMAINP U;
  44. SYMBOLIC SMACRO PROCEDURE MODULE U; NIL;
  45. SYMBOLIC SMACRO PROCEDURE ENDMODULE; NIL;
  46. SYMBOLIC SMACRO PROCEDURE BLKCMP; NIL;
  47. SYMBOLIC SMACRO PROCEDURE EXPORTS U; NIL;
  48. SYMBOLIC SMACRO PROCEDURE IMPORTS U; NIL;
  49. DEFLIST('((MODULE RLIS) (EXPORTS RLIS)
  50. (IMPORTS RLIS) (ENDMODULE ENDSTAT)),'STAT);
  51. SYMBOLIC SMACRO PROCEDURE PRINC U; PRIN2 U;
  52. SYMBOLIC SMACRO PROCEDURE PRINTC U; PRIN2T U;
  53. SYMBOLIC SMACRO PROCEDURE READGCTIME; GCTIME();
  54. SYMBOLIC SMACRO PROCEDURE READTIME; TIME()-GCTIME();
  55. SYMBOLIC SMACRO PROCEDURE REVERSEWOC U; REVERSIP U;
  56. SYMBOLIC SMACRO PROCEDURE TTAB N; SPACES(N-POSN());
  57. % Operators for fast arithmetic;
  58. SYMBOLIC MACRO PROCEDURE IPLUS U; EXPAND(CDR U,'PLUS2);
  59. SYMBOLIC MACRO PROCEDURE ITIMES U; EXPAND(CDR U,'TIMES2);
  60. SMACRO PROCEDURE ISUB1 A; A-1;
  61. SMACRO PROCEDURE IADD1 A; A+1;
  62. SMACRO PROCEDURE IMINUS A; -A;
  63. SMACRO PROCEDURE IDIFFERENCE(A,B); A-B;
  64. SMACRO PROCEDURE IQUOTIENT(A,B); A/B;
  65. SMACRO PROCEDURE IREMAINDER(A,B); REMAINDER(A,B);
  66. SMACRO PROCEDURE IGREATERP(A,B); A>B;
  67. SMACRO PROCEDURE ILESSP(A,B); A<B;
  68. SMACRO PROCEDURE IMINUSP A; A<0;
  69. NEWTOK '((!#) HASH);
  70. NEWTOK '((!# !+) IPLUS);
  71. NEWTOK '((!# !-) IDIFFERENCE);
  72. NEWTOK '((!# !*) ITIMES);
  73. NEWTOK '((!# !/) IQUOTIENT);
  74. NEWTOK '((!# !>) IGREATERP);
  75. NEWTOK '((!# !<) ILESSP);
  76. INFIX #+,#-,#*,#/,#>,#<;
  77. PRECEDENCE #+,+;
  78. PRECEDENCE #-,-;
  79. PRECEDENCE #*,*;
  80. PRECEDENCE #/,/;
  81. PRECEDENCE #>,>;
  82. PRECEDENCE #<,<;
  83. FLAG('(IPLUS ITIMES),'NARY);
  84. DEFLIST('((IDIFFERENCE IMINUS)),'UNARY);
  85. DEFLIST('((IMINUS IPLUS)), 'ALT);
  86. SYMBOLIC PROCEDURE MOVED(OLD,NEW);
  87. << REMD OLD;
  88. PUTD(OLD,'EXPR,CDR GETD NEW) >>;
  89. SMACRO PROCEDURE EVENP A; REMAINDER(A,2)=0;
  90. SMACRO PROCEDURE SUPERPRINT A; PRETTYPRINT A;
  91. %The following number is probably not machine dependent;
  92. GLOBAL '(TWENTYFOURBITS);
  93. TWENTYFOURBITS := 2**24-1;
  94. COMMENT An Exponential Function for Real Numbers;
  95. % The following definitions constitute a simple floating
  96. % point exponential function. The argument is normalized to
  97. % the interval -ln 2 to 0, and a Taylor series expansion
  98. % used (formula 4.2.45 on page 71 of Abramowitz and Stegun,
  99. % "Handbook of Mathematical Functions"). Note that little
  100. % effort has been expended to minimize truncation errors.
  101. % On many systems it will be appropriate to define a system-
  102. % specific EXP routine that does bother about rounding and that
  103. % understands the precision of the host floating point arithmetic;
  104. SYMBOLIC PROCEDURE CEILING!-FLOAT X;
  105. % Returns the ceiling (fixnum) of its floatnum argument;
  106. BEGIN SCALAR N;
  107. N := FIX X;
  108. RETURN IF X = FLOAT N THEN N ELSE N+1
  109. END;
  110. GLOBAL '(EXP!-COEFFS NATURAL!-LOG!-2);
  111. EXP!-COEFFS := MKVECT 7;
  112. PUTV(EXP!-COEFFS,0,1.0);
  113. PUTV(EXP!-COEFFS,1,-1.0);
  114. PUTV(EXP!-COEFFS,2,0.49999992);
  115. PUTV(EXP!-COEFFS,3,-0.16666530);
  116. PUTV(EXP!-COEFFS,4,0.41657347E-1);
  117. PUTV(EXP!-COEFFS,5,-0.83013598E-2);
  118. PUTV(EXP!-COEFFS,6,0.13298820E-2);
  119. PUTV(EXP!-COEFFS,7,-0.14131610E-3);
  120. NATURAL!-LOG!-2 := 0.69314718;
  121. SYMBOLIC PROCEDURE EXP X;
  122. % Returns the exponential (ie, e**x) of its floatnum argument as
  123. % a floatnum;
  124. BEGIN SCALAR N,ANS;
  125. N := CEILING!-FLOAT(X / NATURAL!-LOG!-2);
  126. X := N * NATURAL!-LOG!-2 - X;
  127. ANS := 0.0;
  128. FOR I := UPBV EXP!-COEFFS STEP -1 UNTIL 0 DO
  129. ANS := GETV(EXP!-COEFFS,I) + X*ANS;
  130. RETURN ANS * 2**N
  131. END;
  132. COMMENT A Random Number Generator;
  133. % The declarations below constitute a linear, congruential
  134. % random number generator (see Knuth, "The Art of Computer
  135. % Programming: Volume 2: Seminumerical Algorithms", pp9-24).
  136. % With the given constants it has a period of 392931 and
  137. % potency 6. To have deterministic behaviour, set
  138. % RANDOM!-SEED.
  139. %
  140. % Constants are: 6 2
  141. % modulus: 392931 = 3 * 7 * 11
  142. % multiplier: 232 = 3 * 7 * 11 + 1
  143. % increment: 65537 is prime;
  144. GLOBAL '(RANDOM!-SEED);
  145. SYMBOLIC PROCEDURE RANDOMIZE();
  146. RANDOM!-SEED := REMAINDER(TIME(),392931);
  147. RANDOMIZE();
  148. SYMBOLIC PROCEDURE RANDOM;
  149. % Returns a pseudo-random number between 0 and 392931;
  150. RANDOM!-SEED := REMAINDER(232*RANDOM!-SEED + 65537, 392931);
  151. COMMENT Support for Real Square Roots;
  152. SYMBOLIC PROCEDURE SQRT N;
  153. % return sqrt of n if same is exact, or something non-numeric
  154. % otherwise. Note that only the floating point parts of this
  155. % code get excercised by the factorizer, and that they only
  156. % ever get called with arguments in the range 1 to 10**12;
  157. IF NOT NUMBERP N THEN 'NONNUMERIC
  158. ELSE IF N<0 THEN 'NEGATIVE
  159. ELSE IF FLOATP N THEN SQRT!-FLOAT N
  160. ELSE IF N<2 THEN N
  161. ELSE NR(N,(N+1)/2);
  162. SYMBOLIC PROCEDURE NR(N,ROOT);
  163. % root is an overestimate here. nr moves downwards to root.
  164. % In the case of this being called on really big numbers the
  165. % initial approximate used will be bad & the iteration will start
  166. % in effect by halving it until it is reasonable. This could do
  167. % with improvement in any system where big square roots will be
  168. % taken at all often;
  169. BEGIN
  170. SCALAR W;
  171. W:=ROOT*ROOT;
  172. IF N=W THEN RETURN ROOT;
  173. W:=(ROOT+N/ROOT)/2;
  174. IF W>=ROOT THEN RETURN !*P2F MKSP(LIST('SQRT,N),1);
  175. RETURN NR(N,W)
  176. END;
  177. GLOBAL '(SQRT!-FLOAT!-TOLERANCE);
  178. SQRT!-FLOAT!-TOLERANCE := 0.00001;
  179. SYMBOLIC PROCEDURE SQRT!-FLOAT N;
  180. % Simple Newton-Raphson floating point square root calculator;
  181. BEGIN SCALAR SCALE,ANS;
  182. IF N=0.0 THEN RETURN 0.0
  183. ELSE IF N<0.0 THEN REDERR "SQRT!-FLOAT GIVEN NEGATIVE ARGUMENT";
  184. SCALE := 1.0;
  185. % Detatch the exponent by doing a sequence of multiplications
  186. % and divisions by powers of 2 until the remaining number is in
  187. % the range 1.0 to 4.0. On a binary machine the scaling should
  188. % not introduce any error at all;
  189. WHILE N > 256.0 DO <<
  190. SCALE := SCALE * 16.0;
  191. N := N/256.0 >>;
  192. WHILE N < 1.0/256.0 DO <<
  193. SCALE := SCALE / 16.0;
  194. N := N*256.0 >>; % Coarse scaled: now finish off the job;
  195. WHILE N < 1.0 DO <<
  196. SCALE := SCALE / 2.0;
  197. N := N*4.0 >>;
  198. WHILE N > 4.0 DO <<
  199. SCALE := SCALE * 2.0;
  200. N := N/4.0 >>;
  201. ANS := 2.0; % 5 iterations get me as good a result
  202. % as I can reasonably want & it is cheaper
  203. % to do 5 always than to test for stopping
  204. % criteria;
  205. FOR I:=1:5 DO
  206. ANS := (ANS+N/ANS)/2.0;
  207. RETURN ANS*SCALE
  208. END;
  209. COMMENT A Simple Sorting Routine;
  210. SYMBOLIC PROCEDURE SORT(L,FN);
  211. BEGIN
  212. SCALAR TREE;
  213. IF NULL L OR NULL CDR L THEN RETURN L;
  214. FOR EACH J IN L DO TREE := TREEADD(J,TREE,FN);
  215. RETURN FLATTREE(TREE,NIL)
  216. END;
  217. SYMBOLIC PROCEDURE TREEADD(ITEM,TREE,FN);
  218. % add item to a tree, using fn as an order predicate;
  219. IF NULL TREE THEN ITEM . (NIL . NIL)
  220. ELSE IF APPLY(FN,LIST(ITEM,CAR TREE)) THEN
  221. CAR TREE . (TREEADD(ITEM,CADR TREE,FN). CDDR TREE)
  222. ELSE CAR TREE . (CADR TREE . TREEADD(ITEM,CDDR TREE,FN));
  223. SYMBOLIC PROCEDURE FLATTREE(TREE,L);
  224. IF NULL TREE THEN L
  225. ELSE FLATTREE(CADR TREE,CAR TREE . FLATTREE(CDDR TREE,L));
  226. % Modular arithmetic;
  227. FLUID '(CURRENT!-MODULUS MODULUS!/2
  228. LARGEST!-SMALL!-MODULUS);
  229. % LARGEST!-SMALL!-MODULUS must be set in the front-end (system
  230. % dependent) file;
  231. SYMBOLIC PROCEDURE SET!-SMALL!-MODULUS P;
  232. BEGIN
  233. SCALAR PREVIOUS!-MODULUS;
  234. IF P>LARGEST!-SMALL!-MODULUS
  235. THEN ERRORF "Overlarge modulus being used";
  236. PREVIOUS!-MODULUS:=CURRENT!-MODULUS;
  237. CURRENT!-MODULUS:=P;
  238. MODULUS!/2 := P/2;
  239. RETURN PREVIOUS!-MODULUS
  240. END;
  241. SMACRO PROCEDURE MODULAR!-PLUS(A,B);
  242. BEGIN SCALAR RESULT;
  243. RESULT:=A #+ B;
  244. IF NOT RESULT #< CURRENT!-MODULUS THEN
  245. RESULT:=RESULT #- CURRENT!-MODULUS;
  246. RETURN RESULT
  247. END;
  248. SMACRO PROCEDURE MODULAR!-DIFFERENCE(A,B);
  249. BEGIN SCALAR RESULT;
  250. RESULT:=A #- B;
  251. IF IMINUSP RESULT THEN RESULT:=RESULT #+ CURRENT!-MODULUS;
  252. RETURN RESULT
  253. END;
  254. SYMBOLIC PROCEDURE MODULAR!-NUMBER A;
  255. BEGIN
  256. A:=REMAINDER(A,CURRENT!-MODULUS);
  257. IF IMINUSP A THEN A:=A #+ CURRENT!-MODULUS;
  258. RETURN A
  259. END;
  260. SMACRO PROCEDURE MODULAR!-TIMES(A,B);
  261. REMAINDER(A*B,CURRENT!-MODULUS);
  262. SMACRO PROCEDURE MODULAR!-RECIPROCAL A;
  263. RECIPROCAL!-BY!-GCD(CURRENT!-MODULUS,A,0,1);
  264. SYMBOLIC PROCEDURE RECIPROCAL!-BY!-GCD(A,B,X,Y);
  265. %On input A and B should be coprime. This routine then
  266. %finds X and Y such that A*X+B*Y=1, and returns the value Y
  267. %on input A > B;
  268. IF B=0 THEN ERRORF "INVALID MODULAR DIVISION"
  269. ELSE IF B=1 THEN IF IMINUSP Y THEN Y #+ CURRENT!-MODULUS ELSE Y
  270. ELSE BEGIN SCALAR W;
  271. %N.B. Invalid modular division is either:
  272. % a) attempt to divide by zero directly
  273. % b) modulus is not prime, and input is not
  274. % coprime with it;
  275. W:=IQUOTIENT(A,B); %Truncated integer division;
  276. RETURN RECIPROCAL!-BY!-GCD(B,A #- B #* W,
  277. Y,X #- Y #* W)
  278. END;
  279. SMACRO PROCEDURE MODULAR!-QUOTIENT(A,B);
  280. MODULAR!-TIMES(A,MODULAR!-RECIPROCAL B);
  281. SMACRO PROCEDURE MODULAR!-MINUS A;
  282. IF A=0 THEN A ELSE CURRENT!-MODULUS #- A;
  283. % Comparison functions used with the sort package;
  284. SYMBOLIC PROCEDURE LESSPCAR(A,B);
  285. CAR A < CAR B;
  286. SYMBOLIC PROCEDURE LESSPCDR(A,B);
  287. CDR A < CDR B;
  288. SYMBOLIC PROCEDURE LESSPPAIR(A,B);
  289. IF CAR A=CAR B THEN CDR A < CDR B
  290. ELSE CAR A < CAR B;
  291. SYMBOLIC PROCEDURE GREATERPCDR(A,B);
  292. CDR A > CDR B;
  293. SYMBOLIC PROCEDURE LESSPCDADR(A,B);
  294. CDADR A < CDADR B;
  295. SYMBOLIC PROCEDURE LESSPDEG(A,B);
  296. IF DOMAINP B THEN NIL
  297. ELSE IF DOMAINP A THEN T
  298. ELSE LDEG A < LDEG B;
  299. SYMBOLIC PROCEDURE ORDOPCAR(A,B);
  300. ORDOP(CAR A,CAR B);
  301. SYMBOLIC PROCEDURE ORDERFACTORS(A,B);
  302. IF CDR A=CDR B THEN ORDP(CAR A,CAR B)
  303. ELSE CDR A < CDR B;
  304. % ENDMODULE;
  305. MODULE FLUIDS;
  306. % *******************************************************************
  307. %
  308. % copyright (c) university of cambridge, england 1981
  309. %
  310. % *******************************************************************;
  311. SYMBOLIC PROCEDURE ERRORF MSGG;
  312. BEGIN
  313. TERPRI();
  314. PRIN2 "*** ERROR IN FACTORIZATION: ";
  315. PRIN2 MSGG;
  316. TERPRI();
  317. ERROR(0,'ERRORF)
  318. END;
  319. % macro definitions for functions that create and
  320. % access reduce-type datastructures;
  321. SMACRO PROCEDURE TVAR A;
  322. CAAR A;
  323. FLUID '(POLYZERO);
  324. POLYZERO:=NIL;
  325. SMACRO PROCEDURE POLYZEROP U; NULL U;
  326. SMACRO PROCEDURE DIDNTGO Q; NULL Q;
  327. SMACRO PROCEDURE DEPENDS!-ON!-VAR(A,V);
  328. (LAMBDA !#!#A;
  329. (NOT DOMAINP !#!#A) AND (MVAR !#!#A=V)) A;
  330. SMACRO PROCEDURE L!-NUMERIC!-C(A,VLIST);
  331. LNC A;
  332. % macro definitions for use in berlekamps algorithm;
  333. % SMACROs used in linear equation package;
  334. SMACRO PROCEDURE GETM2(A,I,J);
  335. % Store by rows, to ease pivoting process;
  336. GETV(GETV(A,I),J);
  337. SMACRO PROCEDURE PUTM2(A,I,J,V);
  338. PUTV(GETV(A,I),J,V);
  339. SMACRO PROCEDURE !*D2N A;
  340. % converts domain elt into number;
  341. (LAMBDA !#A!#;
  342. IF NULL !#A!# THEN 0 ELSE !#A!#) A;
  343. SMACRO PROCEDURE !*NUM2F N;
  344. % converts number to s.f. ;
  345. (LAMBDA !#N!#;
  346. IF !#N!#=0 THEN NIL ELSE !#N!#) N;
  347. SMACRO PROCEDURE !*MOD2F U; U;
  348. SMACRO PROCEDURE !*F2MOD U; U;
  349. SMACRO PROCEDURE COMES!-BEFORE(P1,P2);
  350. % Similar to the REDUCE function ORDPP, but does not cater for
  351. % non-commutative terms and assumes that exponents are small
  352. % integers;
  353. (CAR P1=CAR P2 AND IGREATERP(CDR P1,CDR P2)) OR
  354. (NOT CAR P1=CAR P2 AND ORDOP(CAR P1,CAR P2));
  355. SMACRO PROCEDURE ADJOIN!-TERM (P,C,R);
  356. (LAMBDA !#C!#; % Lambda binding prevents repeated evaluation of C;
  357. IF NULL !#C!# THEN R ELSE (P .* !#C!#) .+ R) C;
  358. % a load of access smacros for image sets follow: ;
  359. SMACRO PROCEDURE GET!-IMAGE!-SET S; CAR S;
  360. SMACRO PROCEDURE GET!-CHOSEN!-PRIME S; CADR S;
  361. SMACRO PROCEDURE GET!-IMAGE!-LC S; CADDR S;
  362. SMACRO PROCEDURE GET!-IMAGE!-MOD!-P S; CADR CDDR S;
  363. SMACRO PROCEDURE GET!-IMAGE!-CONTENT S; CADR CDR CDDR S;
  364. SMACRO PROCEDURE GET!-IMAGE!-POLY S; CADR CDDR CDDR S;
  365. SMACRO PROCEDURE GET!-F!-NUMVEC S; CADR CDDR CDDDR S;
  366. SMACRO PROCEDURE PUT!-IMAGE!-POLY!-AND!-CONTENT(S,IMCONT,IMPOL);
  367. LIST(GET!-IMAGE!-SET S,
  368. GET!-CHOSEN!-PRIME S,
  369. GET!-IMAGE!-LC S,
  370. GET!-IMAGE!-MOD!-P S,
  371. IMCONT,
  372. IMPOL,
  373. GET!-F!-NUMVEC S);
  374. FLUID '(
  375. !*GCD
  376. !*EXP
  377. SAFE!-FLAG
  378. BASE!-TIME
  379. GC!-BASE!-TIME
  380. LAST!-DISPLAYED!-TIME
  381. LAST!-DISPLAYED!-GC!-TIME
  382. INPUT!-POLYNOMIAL
  383. PRIMES
  384. CURRENT!-MODULUS
  385. MODULUS!/2
  386. POLY!-MOD!-P
  387. INPUT!-LEADING!-COEFFICIENT
  388. INPUT!-NORM
  389. INPUT!-MAIN!-VARIABLE
  390. NUMBER!-NEEDED
  391. BEST!-VARIABLE
  392. KNOWN!-FACTORS
  393. X!*!*P
  394. DX!*!*P
  395. WORK!-VECTOR1
  396. DWORK1
  397. WORK!-VECTOR2
  398. DWORK2
  399. POLY!-VECTOR
  400. DPOLY
  401. LINEAR!-FACTORS
  402. NULL!-SPACE!-BASIS
  403. SPLIT!-LIST
  404. FACTOR!-COUNT
  405. BEST!-FACTOR!-COUNT
  406. BEST!-KNOWN!-FACTORS
  407. MODULAR!-SPLITTINGS
  408. BEST!-MODULUS
  409. VALID!-IMAGE!-SETS
  410. FACTORED!-LC
  411. MULTIVARIATE!-INPUT!-POLY
  412. BEST!-SET!-POINTER
  413. IMAGE!-FACTORS
  414. TRUE!-LEADING!-COEFFTS
  415. IRREDUCIBLE
  416. INVERTED
  417. INVERTED!-SIGN
  418. NUMBER!-OF!-FACTORS
  419. M!-IMAGE!-VARIABLE
  420. MODULAR!-VALUES
  421. NO!-OF!-RANDOM!-SETS
  422. NO!-OF!-BEST!-SETS
  423. IMAGE!-SET!-MODULUS
  424. !*ALL!-CONTENTS
  425. FACTOR!-X
  426. SFP!-COUNT
  427. FACTOR!-TRACE!-LIST
  428. FACTOR!-LEVEL
  429. !*OVERVIEW
  430. !*OVERSHOOT
  431. NON!-MONIC
  432. !*NEW!-TIMES!-MOD!-P
  433. POLYNOMIAL!-TO!-FACTOR
  434. FORBIDDEN!-SETS
  435. FORBIDDEN!-PRIMES
  436. VARS!-TO!-KILL
  437. ZERO!-SET!-TRIED
  438. BAD!-CASE
  439. PREVIOUS!-DEGREE!-MAP
  440. TARGET!-FACTOR!-COUNT
  441. MODULAR!-INFO
  442. MULTIVARIATE!-FACTORS
  443. IMAGE!-SET
  444. CHOSEN!-PRIME
  445. IMAGE!-LC
  446. IMAGE!-MOD!-P
  447. IMAGE!-CONTENT
  448. IMAGE!-POLY
  449. F!-NUMVEC
  450. VALID!-PRIMES
  451. UNIVARIATE!-INPUT!-POLY
  452. NO!-OF!-RANDOM!-PRIMES
  453. NO!-OF!-BEST!-PRIMES
  454. UNIVARIATE!-FACTORS
  455. !*FORCE!-PRIME
  456. !*FORCE!-ZERO!-SET
  457. !*LINEAR
  458. !*MULTIVARIATE!-TREATMENT
  459. !*TIMINGS
  460. RECONSTRUCTING!-GCD
  461. FULL!-GCD
  462. PREDICTIONS
  463. PRIME!-BASE
  464. ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE
  465. DEGREE!-BOUNDS
  466. UNKNOWNS!-LIST
  467. UNKNOWN
  468. DEG!-OF!-UNKNOWN
  469. DIVISOR!-FOR!-UNKNOWN
  470. DIFFERENCE!-FOR!-UNKNOWN
  471. BEST!-KNOWN!-FACTOR!-LIST
  472. COEFFT!-VECTORS
  473. REDUCED!-DEGREE!-LCLST
  474. UNLUCKY!-CASE
  475. !*KERNREVERSE
  476. EXACT!-QUOTIENT!-FLAG
  477. NUMBER!-OF!-UNKNOWNS
  478. MAX!-UNKNOWNS
  479. USER!-PRIME
  480. NN
  481. !*LINEAR
  482. FACTORS!-DONE
  483. COEFFTBD
  484. HENSEL!-POLY
  485. ZEROVARSET
  486. ZSET
  487. OTHERVARS
  488. SAVE!-ZSET
  489. REDUCTION!-COUNT
  490. );
  491. !*TIMINGS:=NIL; % Default not to displaying timings;
  492. !*OVERSHOOT:=NIL; % Default not to show overshoot occurring;
  493. RECONSTRUCTING!-GCD:=NIL; % This is primarily a factorizer! ;
  494. FLUID '(HENSEL!-GROWTH!-SIZE ALPHALIST);
  495. FLUID '(
  496. FACVEC
  497. FHATVEC
  498. FACTORVEC
  499. MODFVEC
  500. ALPHAVEC
  501. DELFVEC
  502. DELTAM
  503. CURRENT!-FACTOR!-PRODUCT
  504. );
  505. GLOBAL '(POSN!* SPARE!*); %used in TTAB*;
  506. SYMBOLIC PROCEDURE TTAB!* N;
  507. <<
  508. IF N>(LINELENGTH NIL - SPARE!*) THEN N:=0;
  509. IF POSN!* > N THEN TERPRI!*(NIL);
  510. WHILE NOT(POSN!*=N) DO PRIN2!* '! >>;
  511. SMACRO PROCEDURE PRINTSTR L;
  512. << PRIN2!* L; TERPRI!*(NIL) >>;
  513. SYMBOLIC PROCEDURE FAC!-PRINTSF A;
  514. << IF A THEN XPRINF(A,NIL,NIL) ELSE PRIN2!* 0;
  515. TERPRI!* NIL >>;
  516. SMACRO PROCEDURE PRINSF U;
  517. IF U THEN XPRINF(U,NIL,NIL)
  518. ELSE PRIN2!* 0;
  519. SMACRO PROCEDURE PRINTVAR V; PRINTSTR V;
  520. SMACRO PROCEDURE PRINVAR V; PRIN2!* V;
  521. SYMBOLIC PROCEDURE PRINTVEC(STR1,N,STR2,V);
  522. << FOR I:=1:N DO <<
  523. PRIN2!* STR1;
  524. PRIN2!* I;
  525. PRIN2!* STR2;
  526. FAC!-PRINTSF GETV(V,I) >>;
  527. TERPRI!*(NIL) >>;
  528. SMACRO PROCEDURE DISPLAY!-TIME(STR,MT);
  529. % Displays the string str followed by time mt (millisecs);
  530. << PRINC STR; PRINC MT; PRINTC " millisecs." >>;
  531. % trace control package.
  532. %
  533. %;
  534. SMACRO PROCEDURE TRACE!-TIME ACTION;
  535. IF !*TIMINGS THEN ACTION;
  536. SMACRO PROCEDURE NEW!-LEVEL(N,C);
  537. (LAMBDA FACTOR!-LEVEL; C) N;
  538. SYMBOLIC PROCEDURE SET!-TRACE!-FACTOR(N,FILE);
  539. FACTOR!-TRACE!-LIST:=(N . (IF FILE=NIL THEN NIL
  540. ELSE OPEN(MKFIL FILE,'OUTPUT))) .
  541. FACTOR!-TRACE!-LIST;
  542. SYMBOLIC PROCEDURE CLEAR!-TRACE!-FACTOR N;
  543. BEGIN
  544. SCALAR W;
  545. W := ASSOC(N,FACTOR!-TRACE!-LIST);
  546. IF W THEN <<
  547. IF CDR W THEN CLOSE CDR W;
  548. FACTOR!-TRACE!-LIST:=DELASC(N,FACTOR!-TRACE!-LIST) >>;
  549. RETURN NIL
  550. END;
  551. SYMBOLIC PROCEDURE CLOSE!-TRACE!-FILES();
  552. << WHILE FACTOR!-TRACE!-LIST
  553. DO CLEAR!-TRACE!-FACTOR(CAAR FACTOR!-TRACE!-LIST);
  554. NIL >>;
  555. FACTOR!-TRACE!-LIST:=NIL;
  556. FACTOR!-LEVEL:=0; % start with a numeric value;
  557. ENDMODULE;
  558. MODULE ALPHAS;
  559. % *******************************************************************
  560. %
  561. % copyright (c) university of cambridge, england 1979
  562. %
  563. % *******************************************************************;
  564. %********************************************************************;
  565. %
  566. % this section contains access and update functions for the alphas;
  567. SYMBOLIC PROCEDURE GET!-ALPHA POLY;
  568. % gets the poly and its associated alpha from the current alphalist
  569. % if poly is not on the alphalist then we force an error;
  570. BEGIN SCALAR W;
  571. W:=ASSOC!-ALPHA(POLY,ALPHALIST);
  572. IF NULL W THEN ERRORF LIST("Alpha not found for ",POLY," in ",
  573. ALPHALIST);
  574. RETURN W
  575. END;
  576. SYMBOLIC PROCEDURE DIVIDE!-ALL!-ALPHAS N;
  577. % multiply the factors by n mod p and alter the alphas accordingly;
  578. BEGIN SCALAR OM,M;
  579. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  580. M:=MODULAR!-EXPT(
  581. MODULAR!-RECIPROCAL MODULAR!-NUMBER N,
  582. NUMBER!-OF!-FACTORS #- 1);
  583. ALPHALIST:=FOR EACH A IN ALPHALIST COLLECT
  584. (TIMES!-MOD!-P(N,CAR A) . TIMES!-MOD!-P(M,CDR A));
  585. SET!-MODULUS OM
  586. END;
  587. SYMBOLIC PROCEDURE MULTIPLY!-ALPHAS(N,OLDPOLY,NEWPOLY);
  588. % multiply all the alphas except the one associated with oldpoly
  589. % by n mod p. also replace oldpoly by newpoly in the alphalist;
  590. BEGIN SCALAR OM,FACA,W;
  591. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  592. N:=MODULAR!-NUMBER N;
  593. OLDPOLY:=REDUCE!-MOD!-P OLDPOLY;
  594. FACA:=GET!-ALPHA OLDPOLY;
  595. ALPHALIST:=DELETE(FACA,ALPHALIST);
  596. ALPHALIST:=FOR EACH A IN ALPHALIST COLLECT
  597. CAR A . TIMES!-MOD!-P(CDR A,N);
  598. ALPHALIST:=(REDUCE!-MOD!-P NEWPOLY . CDR FACA) . ALPHALIST;
  599. SET!-MODULUS OM
  600. END;
  601. SYMBOLIC PROCEDURE MULTIPLY!-ALPHAS!-RECIP(N,OLDPOLY,NEWPOLY);
  602. % multiply all the alphas except the one associated with oldpoly
  603. % by the reciprocal mod p of n. also replace oldpoly by newpoly;
  604. BEGIN SCALAR OM,W;
  605. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  606. N:=MODULAR!-RECIPROCAL MODULAR!-NUMBER N;
  607. W:=MULTIPLY!-ALPHAS(N,OLDPOLY,NEWPOLY);
  608. SET!-MODULUS OM;
  609. RETURN W
  610. END;
  611. ENDMODULE;
  612. MODULE BIGMODP;
  613. % (C) Copyright 1981, University of Cambridge;
  614. % Modular arithmetic where the modulus may be a bignum.
  615. % Currently only called from section UNIHENS;
  616. SYMBOLIC PROCEDURE SET!-GENERAL!-MODULUS P;
  617. IF NOT NUMBERP P THEN CURRENT!-MODULUS
  618. ELSE BEGIN
  619. SCALAR PREVIOUS!-MODULUS;
  620. PREVIOUS!-MODULUS:=CURRENT!-MODULUS;
  621. CURRENT!-MODULUS:=P;
  622. MODULUS!/2 := P/2;
  623. RETURN PREVIOUS!-MODULUS
  624. END;
  625. SYMBOLIC PROCEDURE GENERAL!-PLUS!-MOD!-P(A,B);
  626. % form the sum of the two polynomials a and b
  627. % working over the ground domain defined by the routines
  628. % general!-modular!-plus, general!-modular!-times etc. the inputs to
  629. % this routine are assumed to have coefficients already
  630. % in the required domain;
  631. IF NULL A THEN B
  632. ELSE IF NULL B THEN A
  633. ELSE IF ISDOMAIN A THEN
  634. IF ISDOMAIN B THEN !*NUM2F GENERAL!-MODULAR!-PLUS(A,B)
  635. ELSE (LT B) .+ GENERAL!-PLUS!-MOD!-P(A,RED B)
  636. ELSE IF ISDOMAIN B THEN (LT A) .+ GENERAL!-PLUS!-MOD!-P(RED A,B)
  637. ELSE IF LPOW A = LPOW B THEN
  638. ADJOIN!-TERM(LPOW A,
  639. GENERAL!-PLUS!-MOD!-P(LC A,LC B),
  640. GENERAL!-PLUS!-MOD!-P(RED A,RED B))
  641. ELSE IF COMES!-BEFORE(LPOW A,LPOW B) THEN
  642. (LT A) .+ GENERAL!-PLUS!-MOD!-P(RED A,B)
  643. ELSE (LT B) .+ GENERAL!-PLUS!-MOD!-P(A,RED B);
  644. SYMBOLIC PROCEDURE GENERAL!-TIMES!-MOD!-P(A,B);
  645. IF (NULL A) OR (NULL B) THEN NIL
  646. ELSE IF ISDOMAIN A THEN GEN!-MULT!-BY!-CONST!-MOD!-P(B,A)
  647. ELSE IF ISDOMAIN B THEN GEN!-MULT!-BY!-CONST!-MOD!-P(A,B)
  648. ELSE IF MVAR A=MVAR B THEN GENERAL!-PLUS!-MOD!-P(
  649. GENERAL!-PLUS!-MOD!-P(GENERAL!-TIMES!-TERM!-MOD!-P(LT A,B),
  650. GENERAL!-TIMES!-TERM!-MOD!-P(LT B,RED A)),
  651. GENERAL!-TIMES!-MOD!-P(RED A,RED B))
  652. ELSE IF ORDOP(MVAR A,MVAR B) THEN
  653. ADJOIN!-TERM(LPOW A,GENERAL!-TIMES!-MOD!-P(LC A,B),
  654. GENERAL!-TIMES!-MOD!-P(RED A,B))
  655. ELSE ADJOIN!-TERM(LPOW B,
  656. GENERAL!-TIMES!-MOD!-P(A,LC B),GENERAL!-TIMES!-MOD!-P(A,RED B));
  657. SYMBOLIC PROCEDURE GENERAL!-TIMES!-TERM!-MOD!-P(TERM,B);
  658. %multiply the given polynomial by the given term;
  659. IF NULL B THEN NIL
  660. ELSE IF ISDOMAIN B THEN
  661. ADJOIN!-TERM(TPOW TERM,
  662. GEN!-MULT!-BY!-CONST!-MOD!-P(TC TERM,B),NIL)
  663. ELSE IF TVAR TERM=MVAR B THEN
  664. ADJOIN!-TERM(MKSP(TVAR TERM,IPLUS(TDEG TERM,LDEG B)),
  665. GENERAL!-TIMES!-MOD!-P(TC TERM,LC B),
  666. GENERAL!-TIMES!-TERM!-MOD!-P(TERM,RED B))
  667. ELSE IF ORDOP(TVAR TERM,MVAR B) THEN
  668. ADJOIN!-TERM(TPOW TERM,GENERAL!-TIMES!-MOD!-P(TC TERM,B),NIL)
  669. ELSE ADJOIN!-TERM(LPOW B,
  670. GENERAL!-TIMES!-TERM!-MOD!-P(TERM,LC B),
  671. GENERAL!-TIMES!-TERM!-MOD!-P(TERM,RED B));
  672. SYMBOLIC PROCEDURE GEN!-MULT!-BY!-CONST!-MOD!-P(A,N);
  673. % multiply the polynomial a by the constant n;
  674. IF NULL A THEN NIL
  675. ELSE IF N=1 THEN A
  676. ELSE IF ISDOMAIN A THEN !*NUM2F GENERAL!-MODULAR!-TIMES(A,N)
  677. ELSE ADJOIN!-TERM(LPOW A,GEN!-MULT!-BY!-CONST!-MOD!-P(LC A,N),
  678. GEN!-MULT!-BY!-CONST!-MOD!-P(RED A,N));
  679. SYMBOLIC PROCEDURE GENERAL!-DIFFERENCE!-MOD!-P(A,B);
  680. GENERAL!-PLUS!-MOD!-P(A,GENERAL!-MINUS!-MOD!-P B);
  681. SYMBOLIC PROCEDURE GENERAL!-MINUS!-MOD!-P A;
  682. IF NULL A THEN NIL
  683. ELSE IF ISDOMAIN A THEN GENERAL!-MODULAR!-MINUS A
  684. ELSE (LPOW A .* GENERAL!-MINUS!-MOD!-P LC A) .+
  685. GENERAL!-MINUS!-MOD!-P RED A;
  686. SYMBOLIC PROCEDURE GENERAL!-REDUCE!-MOD!-P A;
  687. %converts a multivariate poly from normal into modular polynomial;
  688. IF NULL A THEN NIL
  689. ELSE IF ISDOMAIN A THEN !*NUM2F GENERAL!-MODULAR!-NUMBER A
  690. ELSE ADJOIN!-TERM(LPOW A,
  691. GENERAL!-REDUCE!-MOD!-P LC A,
  692. GENERAL!-REDUCE!-MOD!-P RED A);
  693. SYMBOLIC PROCEDURE GENERAL!-MAKE!-MODULAR!-SYMMETRIC A;
  694. % input is a multivariate MODULAR poly A with nos in the range 0->(p-1).
  695. % This folds it onto the symmetric range (-p/2)->(p/2);
  696. IF NULL A THEN NIL
  697. ELSE IF DOMAINP A THEN
  698. IF A>MODULUS!/2 THEN !*NUM2F(A - CURRENT!-MODULUS)
  699. ELSE A
  700. ELSE ADJOIN!-TERM(LPOW A,
  701. GENERAL!-MAKE!-MODULAR!-SYMMETRIC LC A,
  702. GENERAL!-MAKE!-MODULAR!-SYMMETRIC RED A);
  703. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-PLUS(A,B);
  704. BEGIN SCALAR RESULT;
  705. RESULT:=A+B;
  706. IF RESULT >= CURRENT!-MODULUS THEN RESULT:=RESULT-CURRENT!-MODULUS;
  707. RETURN RESULT
  708. END;
  709. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-DIFFERENCE(A,B);
  710. BEGIN SCALAR RESULT;
  711. RESULT:=A-B;
  712. IF RESULT < 0 THEN RESULT:=RESULT+CURRENT!-MODULUS;
  713. RETURN RESULT
  714. END;
  715. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-NUMBER A;
  716. BEGIN
  717. A:=REMAINDER(A,CURRENT!-MODULUS);
  718. IF A < 0 THEN A:=A+CURRENT!-MODULUS;
  719. RETURN A
  720. END;
  721. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-TIMES(A,B);
  722. BEGIN SCALAR RESULT;
  723. RESULT:=REMAINDER(A*B,CURRENT!-MODULUS);
  724. IF RESULT < 0 THEN RESULT:=RESULT+CURRENT!-MODULUS;
  725. RETURN RESULT
  726. END;
  727. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-RECIPROCAL A;
  728. BEGIN
  729. RETURN RECIPROCAL!-BY!-GCD(CURRENT!-MODULUS,A,0,1)
  730. END;
  731. SYMBOLIC PROCEDURE RECIPROCAL!-BY!-GCD(A,B,X,Y);
  732. %On input A and B should be coprime. This routine then
  733. %finds X and Y such that A*X+B*Y=1, and returns the value Y
  734. %on input A > B;
  735. IF B=0 THEN ERRORF "INVALID MODULAR DIVISION"
  736. ELSE IF B=1 THEN IF Y < 0 THEN Y+CURRENT!-MODULUS ELSE Y
  737. ELSE BEGIN SCALAR W;
  738. %N.B. Invalid modular division is either:
  739. % a) attempt to divide by zero directly
  740. % b) modulus is not prime, and input is not
  741. % coprime with it;
  742. W:=QUOTIENT(A,B); %Truncated integer division;
  743. RETURN RECIPROCAL!-BY!-GCD(B,A-B*W,Y,X-Y*W)
  744. END;
  745. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-QUOTIENT(A,B);
  746. GENERAL!-MODULAR!-TIMES(A,GENERAL!-MODULAR!-RECIPROCAL B);
  747. SYMBOLIC PROCEDURE GENERAL!-MODULAR!-MINUS A;
  748. IF A=0 THEN A ELSE CURRENT!-MODULUS - A;
  749. ENDMODULE;
  750. MODULE COEFFTS;
  751. % *******************************************************************
  752. %
  753. % copyright (c) university of cambridge, england 1979
  754. %
  755. % *******************************************************************;
  756. %**********************************************************************;
  757. % code for trying to determine more multivariate coefficients
  758. % by inspection before using multivariate hensel construction. ;
  759. SYMBOLIC PROCEDURE DETERMINE!-MORE!-COEFFTS();
  760. % ...;
  761. BEGIN SCALAR UNKNOWNS!-LIST,UV,R,W,BEST!-KNOWN!-FACTOR!-LIST;
  762. BEST!-KNOWN!-FACTORS:=MKVECT NUMBER!-OF!-FACTORS;
  763. UV:=MKVECT NUMBER!-OF!-FACTORS;
  764. FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO
  765. PUTV(UV,I,CONVERT!-FACTOR!-TO!-TERMVECTOR(
  766. GETV(IMAGE!-FACTORS,I),GETV(TRUE!-LEADING!-COEFFTS,I)));
  767. R:=RED MULTIVARIATE!-INPUT!-POLY;
  768. % we know all about the leading coeffts;
  769. IF NOT DEPENDS!-ON!-VAR(R,M!-IMAGE!-VARIABLE)
  770. OR NULL(W:=TRY!-FIRST!-COEFFT(
  771. LDEG R,LC R,UNKNOWNS!-LIST,UV)) THEN <<
  772. FOR I:=1:NUMBER!-OF!-FACTORS DO
  773. PUTV(BEST!-KNOWN!-FACTORS,I,FORCE!-LC(
  774. GETV(IMAGE!-FACTORS,I),GETV(TRUE!-LEADING!-COEFFTS,I)));
  775. COEFFT!-VECTORS:=UV;
  776. RETURN NIL >>;
  777. FACTOR!-TRACE <<
  778. PRINTSTR
  779. "By exploiting any sparsity wrt the main variable in the";
  780. PRINTSTR "factors, we can try guessing some of the multivariate";
  781. PRINTSTR "coefficients." >>;
  782. TRY!-OTHER!-COEFFTS(R,UNKNOWNS!-LIST,UV);
  783. W:=CONVERT!-AND!-TRIAL!-DIVIDE UV;
  784. TRACE!-TIME
  785. IF FULL!-GCD THEN PRINTC "Possible gcd found"
  786. ELSE PRINTC "Have found some coefficients";
  787. RETURN SET!-UP!-GLOBALS(UV,W)
  788. END;
  789. SYMBOLIC PROCEDURE CONVERT!-FACTOR!-TO!-TERMVECTOR(U,TLC);
  790. % ...;
  791. BEGIN SCALAR TERMLIST,RES,N,SLIST;
  792. TERMLIST:=(LDEG U . TLC) . LIST!-TERMS!-IN!-FACTOR RED U;
  793. RES:=MKVECT (N:=LENGTH TERMLIST);
  794. FOR I:=1:N DO <<
  795. SLIST:=(CAAR TERMLIST . I) . SLIST;
  796. PUTV(RES,I,CAR TERMLIST);
  797. TERMLIST:=CDR TERMLIST >>;
  798. PUTV(RES,0,(N . (N #- 1)));
  799. UNKNOWNS!-LIST:=(REVERSEWOC SLIST) . UNKNOWNS!-LIST;
  800. RETURN RES
  801. END;
  802. SYMBOLIC PROCEDURE TRY!-FIRST!-COEFFT(N,C,SLIST,UV);
  803. % ...;
  804. BEGIN SCALAR COMBNS,UNKNOWN,W,L,D,V,M;
  805. COMBNS:=GET!-TERM(N,SLIST);
  806. IF (COMBNS='NO) OR NOT NULL CDR COMBNS THEN RETURN NIL;
  807. L:=CAR COMBNS;
  808. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  809. W:=GETV(GETV(UV,I),CAR L); % degree . coefft ;
  810. IF NULL CDR W THEN <<
  811. UNKNOWN:=(I . CAR L);
  812. D:=CAR W >>
  813. ELSE <<
  814. C:=QUOTF(C,CDR W);
  815. IF DIDNTGO C THEN RETURN >>;
  816. L:=CDR L >>;
  817. IF DIDNTGO C THEN RETURN NIL;
  818. PUTV(V:=GETV(UV,CAR UNKNOWN),CDR UNKNOWN,(D . C));
  819. M:=GETV(V,0);
  820. PUTV(V,0,(CAR M . (CDR M #- 1)));
  821. IF CDR M = 1 AND FACTORS!-COMPLETE UV THEN RETURN 'COMPLETE;
  822. RETURN C
  823. END;
  824. SYMBOLIC PROCEDURE SOLVE!-NEXT!-COEFFT(N,C,SLIST,UV);
  825. % ...;
  826. BEGIN SCALAR COMBNS,W,UNKNOWN,DEG!-OF!-UNKNOWN,DIVISOR!-FOR!-UNKNOWN,
  827. DIFFERENCE!-FOR!-UNKNOWN,V;
  828. DIFFERENCE!-FOR!-UNKNOWN:=POLYZERO;
  829. DIVISOR!-FOR!-UNKNOWN:=POLYZERO;
  830. COMBNS:=GET!-TERM(N,SLIST);
  831. IF COMBNS='NO THEN RETURN 'NOGOOD;
  832. WHILE COMBNS DO <<
  833. W:=SPLIT!-TERM!-LIST(CAR COMBNS,UV);
  834. IF W='NOGOOD THEN RETURN W;
  835. COMBNS:=CDR COMBNS >>;
  836. IF W='NOGOOD THEN RETURN W;
  837. IF NULL UNKNOWN THEN RETURN;
  838. W:=QUOTF(ADDF(C,NEGF DIFFERENCE!-FOR!-UNKNOWN),
  839. DIVISOR!-FOR!-UNKNOWN);
  840. IF DIDNTGO W THEN RETURN 'NOGOOD;
  841. PUTV(V:=GETV(UV,CAR UNKNOWN),CDR UNKNOWN,(DEG!-OF!-UNKNOWN . W));
  842. N:=GETV(V,0);
  843. PUTV(V,0,(CAR N . (CDR N #- 1)));
  844. IF CDR N = 1 AND FACTORS!-COMPLETE UV THEN RETURN 'COMPLETE;
  845. RETURN W
  846. END;
  847. SYMBOLIC PROCEDURE SPLIT!-TERM!-LIST(TERM!-COMBN,UV);
  848. % ...;
  849. BEGIN SCALAR A,V,W;
  850. A:=1;
  851. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  852. W:=GETV(GETV(UV,I),CAR TERM!-COMBN); % degree . coefft ;
  853. IF NULL CDR W THEN
  854. IF V OR (UNKNOWN AND NOT((I.CAR TERM!-COMBN)=UNKNOWN)) THEN
  855. RETURN V:='NOGOOD
  856. ELSE <<
  857. UNKNOWN:=(I . CAR TERM!-COMBN);
  858. DEG!-OF!-UNKNOWN:=CAR W;
  859. V:=UNKNOWN >>
  860. ELSE A:=MULTF(A,CDR W);
  861. TERM!-COMBN:=CDR TERM!-COMBN >>;
  862. IF V='NOGOOD THEN RETURN V;
  863. IF V THEN DIVISOR!-FOR!-UNKNOWN:=ADDF(DIVISOR!-FOR!-UNKNOWN,A)
  864. ELSE DIFFERENCE!-FOR!-UNKNOWN:=ADDF(DIFFERENCE!-FOR!-UNKNOWN,A);
  865. RETURN 'OK
  866. END;
  867. SYMBOLIC PROCEDURE FACTORS!-COMPLETE UV;
  868. % ...;
  869. BEGIN SCALAR FACTOR!-NOT!-DONE,R;
  870. R:=T;
  871. FOR I:=1:NUMBER!-OF!-FACTORS DO
  872. IF NOT(CDR GETV(GETV(UV,I),0)=0) THEN
  873. IF FACTOR!-NOT!-DONE THEN RETURN R:=NIL
  874. ELSE FACTOR!-NOT!-DONE:=T;
  875. RETURN R
  876. END;
  877. SYMBOLIC PROCEDURE CONVERT!-AND!-TRIAL!-DIVIDE UV;
  878. % ...;
  879. BEGIN SCALAR W,R,FDONE!-PRODUCT!-MOD!-P,OM;
  880. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  881. FDONE!-PRODUCT!-MOD!-P:=1;
  882. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  883. W:=GETV(UV,I);
  884. W:= IF (CDR GETV(W,0))=0 THEN TERMVECTOR2SF W
  885. ELSE MERGE!-TERMS(GETV(IMAGE!-FACTORS,I),W);
  886. R:=QUOTF(MULTIVARIATE!-INPUT!-POLY,W);
  887. IF DIDNTGO R THEN BEST!-KNOWN!-FACTOR!-LIST:=
  888. ((I . W) . BEST!-KNOWN!-FACTOR!-LIST)
  889. ELSE IF RECONSTRUCTING!-GCD AND I=1 THEN RETURN
  890. FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS(
  891. LIST W,M!-IMAGE!-VARIABLE,NIL) ELSE W
  892. ELSE <<
  893. MULTIVARIATE!-FACTORS:=W . MULTIVARIATE!-FACTORS;
  894. FDONE!-PRODUCT!-MOD!-P:=TIMES!-MOD!-P(
  895. REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I),
  896. FDONE!-PRODUCT!-MOD!-P);
  897. MULTIVARIATE!-INPUT!-POLY:=R >> >>;
  898. IF FULL!-GCD THEN RETURN;
  899. IF NULL BEST!-KNOWN!-FACTOR!-LIST THEN MULTIVARIATE!-FACTORS:=
  900. PRIMITIVE!.PARTS(MULTIVARIATE!-FACTORS,M!-IMAGE!-VARIABLE,NIL)
  901. ELSE IF NULL CDR BEST!-KNOWN!-FACTOR!-LIST THEN <<
  902. IF RECONSTRUCTING!-GCD THEN
  903. IF NOT(CAAR BEST!-KNOWN!-FACTOR!-LIST=1) THEN
  904. ERRORF("gcd is jiggered in determining other coeffts")
  905. ELSE FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS(
  906. LIST MULTIVARIATE!-INPUT!-POLY,
  907. M!-IMAGE!-VARIABLE,NIL)
  908. ELSE MULTIVARIATE!-INPUT!-POLY
  909. ELSE MULTIVARIATE!-FACTORS:=PRIMITIVE!.PARTS(
  910. MULTIVARIATE!-INPUT!-POLY . MULTIVARIATE!-FACTORS,
  911. M!-IMAGE!-VARIABLE,NIL);
  912. BEST!-KNOWN!-FACTOR!-LIST:=NIL >>;
  913. FACTOR!-TRACE <<
  914. IF NULL BEST!-KNOWN!-FACTOR!-LIST THEN
  915. PRINTSTR
  916. "We have completely determined all the factors this way"
  917. ELSE IF MULTIVARIATE!-FACTORS THEN <<
  918. PRIN2!* "We have completely determined the following factor";
  919. PRINTSTR IF (LENGTH MULTIVARIATE!-FACTORS)=1 THEN ":" ELSE "s:";
  920. FOR EACH WW IN MULTIVARIATE!-FACTORS DO FAC!-PRINTSF WW >> >>;
  921. SET!-MODULUS OM;
  922. RETURN FDONE!-PRODUCT!-MOD!-P
  923. END;
  924. SYMBOLIC PROCEDURE SET!-UP!-GLOBALS(UV,F!-PRODUCT);
  925. IF NULL BEST!-KNOWN!-FACTOR!-LIST OR FULL!-GCD THEN 'DONE
  926. ELSE BEGIN SCALAR I,R,N,K,FLIST!-MOD!-P,IMF,OM,SAVEK;
  927. N:=LENGTH BEST!-KNOWN!-FACTOR!-LIST;
  928. BEST!-KNOWN!-FACTORS:=MKVECT N;
  929. COEFFT!-VECTORS:=MKVECT N;
  930. R:=MKVECT N;
  931. K:=IF RECONSTRUCTING!-GCD THEN 1 ELSE 0;
  932. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  933. FOR EACH W IN BEST!-KNOWN!-FACTOR!-LIST DO <<
  934. I:=CAR W; W:=CDR W;
  935. IF RECONSTRUCTING!-GCD AND I=1 THEN << SAVEK:=K; K:=1 >>
  936. ELSE K:=K #+ 1;
  937. % in case we are reconstructing gcd we had better know
  938. % which is the gcd and which the cofactor - so don't move
  939. % move the gcd from elt one;
  940. PUTV(R,K,IMF:=GETV(IMAGE!-FACTORS,I));
  941. FLIST!-MOD!-P:=(REDUCE!-MOD!-P IMF) . FLIST!-MOD!-P;
  942. PUTV(BEST!-KNOWN!-FACTORS,K,W);
  943. PUTV(COEFFT!-VECTORS,K,GETV(UV,I));
  944. IF RECONSTRUCTING!-GCD AND K=1 THEN K:=SAVEK;
  945. % restore k if necessary;
  946. >>;
  947. IF NOT(N=NUMBER!-OF!-FACTORS) THEN <<
  948. ALPHALIST:=FOR EACH MODF IN FLIST!-MOD!-P COLLECT
  949. (MODF . REMAINDER!-MOD!-P(TIMES!-MOD!-P(F!-PRODUCT,
  950. CDR GET!-ALPHA MODF),MODF));
  951. NUMBER!-OF!-FACTORS:=N >>;
  952. SET!-MODULUS OM;
  953. IMAGE!-FACTORS:=R;
  954. RETURN 'NEED! TO! RECONSTRUCT
  955. END;
  956. SYMBOLIC PROCEDURE GET!-TERM(N,L);
  957. % ...;
  958. IF N#<0 THEN 'NO
  959. ELSE IF NULL CDR L THEN GET!-TERM!-N(N,CAR L)
  960. ELSE BEGIN SCALAR W,RES;
  961. FOR EACH FTERM IN CAR L DO <<
  962. W:=GET!-TERM(N#-CAR FTERM,CDR L);
  963. IF NOT(W='NO) THEN RES:=
  964. APPEND(FOR EACH V IN W COLLECT (CDR FTERM . V),RES) >>;
  965. RETURN IF NULL RES THEN 'NO ELSE RES
  966. END;
  967. SYMBOLIC PROCEDURE GET!-TERM!-N(N,U);
  968. IF NULL U OR N #> CAAR U THEN 'NO
  969. ELSE IF CAAR U = N THEN LIST(CDAR U . NIL)
  970. ELSE GET!-TERM!-N(N,CDR U);
  971. ENDMODULE;
  972. MODULE CPRES;
  973. % part of resultant program;
  974. SYMBOLIC PROCEDURE CPRES(A,B,X);
  975. % calculates res(A,B) wrt X modulo p;
  976. % A and B are multivariate polynomials modulo p with X as main variable;
  977. BEGIN
  978. INTEGER K, MR, MQ, NR, NQ, NUM!-B, LOOP!-COUNT;
  979. SCALAR C, D, NEW!-A, NEW!-B, NEW!-C, Q, V;
  980. IF NOT (MVAR A=X AND MVAR B=X)
  981. THEN ERRORF "VARIABLE IS NOT IN BOTH POLYNOMIALS";
  982. V := DELETE(X,UNION(VARIABLES!-IN!-FORM A,VARIABLES!-IN!-FORM B));
  983. IF (V = NIL) THEN RETURN NATURAL!-PRS!-ALGORITHM(A,B,X); % simple case;
  984. Q := CAR V; % Q is some variable other than X occuring in A or B;
  985. MR := LDEG A;
  986. NR := LDEG B;
  987. MQ := DEGREE!-IN!-VARIABLE(A,Q);
  988. NQ := DEGREE!-IN!-VARIABLE(B,Q);
  989. K := MR*NQ + NR*MQ; COMMENT limit of degree of resultant in Q;
  990. COMMENT I think the given value is wrong;
  991. % PRINTC "VALUE OF K IS";
  992. % SUPERPRINT K;
  993. % initialise variables ;
  994. C := 0;
  995. D := 1;
  996. NUM!-B := -1;
  997. NEW!-A := A;
  998. NEW!-B := B;
  999. % main loop starts here;
  1000. WHILE (LEADING!-DEGREE D <= K)
  1001. DO BEGIN
  1002. LOOP!-COUNT := 0; % ensures going round inner loop >= once;
  1003. % I'd use a boolean but there aren't any;
  1004. % PRINTC "VALUE OF D IS";
  1005. % SUPERPRINT D;
  1006. WHILE ((DEGREE!-IN!-VARIABLE(NEW!-A,X) < MR)
  1007. OR (DEGREE!-IN!-VARIABLE(NEW!-B,X) < NR)
  1008. OR (LOOP!-COUNT = 0))
  1009. DO BEGIN
  1010. LOOP!-COUNT := 1;
  1011. NUM!-B := NUM!-B + 1;
  1012. IF (NUM!-B=SET!-MODULUS 0) THEN ERRORF "PRIME TOO SMALL";
  1013. NEW!-A := EVALUATE!-MOD!-P(A,Q,NUM!-B);
  1014. NEW!-B := EVALUATE!-MOD!-P(B,Q,NUM!-B);
  1015. % PRINTC "NEW!-A AND NEW!-B ARE";
  1016. % SUPERPRINT NEW!-A;
  1017. % SUPERPRINT NEW!-B;
  1018. END;
  1019. % PRINTC "RECURSE HERE";
  1020. NEW!-C := CPRES(NEW!-A,NEW!-B,X); COMMENT recursion applied;
  1021. % PRINTC "VALUE OF NEW!-C AFTER RECURSION IS";
  1022. % SUPERPRINT NEW!-C;
  1023. % PRINTC "VALUE OF NUM!-B IS";
  1024. % SUPERPRINT NUM!-B;
  1025. % PRINTC "INTERPOLATE HERE";
  1026. C := INTERPOLATE (D,NUM!-B,C,NEW!-C,Q);
  1027. % PRINTC "VALUE OF C AFTER INTERPOLATION IS";
  1028. % SUPERPRINT C;
  1029. D := TIMES!-MOD!-P(DIFFERENCE!-MOD!-P
  1030. (!*K2F Q,!*N2F NUM!-B),D)
  1031. END;
  1032. RETURN C
  1033. END;
  1034. SYMBOLIC PROCEDURE INTERPOLATE(POLY!-D,NUMBER!-B,POLY!-A,POLY!-C,VAR);
  1035. % inputs - D = PI(xr - bi) for 0<=i<=k where the bi are distinct ;
  1036. % elements of GF(p) - B is an element of GF(p) distinct from the ;
  1037. % bi - A(x1 ... xr) is a poly mod p of degree k or less in xr ;
  1038. % - C(x1 ... xr-1) is a poly mod p ;
  1039. % outputs H(x1 ... xr) of degree k+1 or less in xr where H ;
  1040. % interpolates A for all points xr=bi and also H = C when xr=B ;
  1041. % VAR = xr ;
  1042. PLUS!-MOD!-P(POLY!-A,
  1043. TIMES!-MOD!-P(QUOTIENT!-MOD!-P(POLY!-D,
  1044. EVALUATE!-MOD!-P(POLY!-D,
  1045. VAR,
  1046. NUMBER!-B)),
  1047. DIFFERENCE!-MOD!-P(POLY!-C,
  1048. EVALUATE!-MOD!-P(POLY!-A,
  1049. VAR,
  1050. NUMBER!-B))));
  1051. SYMBOLIC PROCEDURE MAIN!-VARIABLE A;
  1052. % returns mvar a unless a is numeric, in which case returns nil;
  1053. IF ISDOMAIN A THEN NIL
  1054. ELSE MVAR A;
  1055. ENDMODULE;
  1056. MODULE DEGSETS;
  1057. %**********************************************************************;
  1058. %
  1059. % copyright (c) university of cambridge, england 1979
  1060. %
  1061. %**********************************************************************;
  1062. %**********************************************************************;
  1063. %
  1064. % degree set processing
  1065. %;
  1066. SYMBOLIC PROCEDURE CHECK!-DEGREE!-SETS(N,MULTIVARIATE!-CASE);
  1067. % MODULAR!-INFO (vector of size N) contains the
  1068. % modular factors now;
  1069. BEGIN SCALAR DEGREE!-SETS,W,X!-IS!-FACTOR,DEGS;
  1070. W:=SPLIT!-LIST;
  1071. FOR I:=1:N DO <<
  1072. IF MULTIVARIATE!-CASE THEN
  1073. X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT
  1074. GETV(VALID!-IMAGE!-SETS,CDAR W);
  1075. DEGS:=FOR EACH V IN GETV(MODULAR!-INFO,CDAR W) COLLECT LDEG V;
  1076. DEGREE!-SETS:=
  1077. (IF X!-IS!-FACTOR THEN 1 . DEGS ELSE DEGS)
  1078. . DEGREE!-SETS;
  1079. W:=CDR W >>;
  1080. CHECK!-DEGREE!-SETS!-1 DEGREE!-SETS;
  1081. BEST!-SET!-POINTER:=CDAR SPLIT!-LIST;
  1082. IF MULTIVARIATE!-CASE AND FACTORED!-LC THEN <<
  1083. WHILE NULL(W:=GET!-F!-NUMVEC
  1084. GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER))
  1085. AND (SPLIT!-LIST:=CDR SPLIT!-LIST) DO
  1086. BEST!-SET!-POINTER:=CDAR SPLIT!-LIST;
  1087. IF NULL W THEN BAD!-CASE:=T >>;
  1088. % make sure the set is ok for distributing the
  1089. % leading coefft where necessary;
  1090. END;
  1091. SYMBOLIC PROCEDURE CHECK!-DEGREE!-SETS!-1 L;
  1092. % L is a list of degree sets. Try to discover if the entries
  1093. % in it are consistent, or if they imply that some of the
  1094. % modular splittings were 'false';
  1095. BEGIN
  1096. SCALAR I,DEGREE!-MAP,DEGREE!-MAP1,DPOLY,
  1097. PLAUSIBLE!-SPLIT!-FOUND,TARGET!-COUNT;
  1098. FACTOR!-TRACE <<
  1099. PRINTC "Degree sets are:";
  1100. FOR EACH S IN L DO <<
  1101. PRINC " ";
  1102. FOR EACH N IN S DO <<
  1103. PRINC " "; PRINC N >>;
  1104. TERPRI() >> >>;
  1105. DPOLY:=SUM!-LIST CAR L;
  1106. TARGET!-COUNT:=LENGTH CAR L;
  1107. FOR EACH S IN CDR L DO TARGET!-COUNT:=IMIN(TARGET!-COUNT,
  1108. LENGTH S);
  1109. IF NULL PREVIOUS!-DEGREE!-MAP THEN <<
  1110. DEGREE!-MAP:=MKVECT DPOLY;
  1111. % To begin with all degrees of factors may be possible;
  1112. FOR I:=0:DPOLY DO PUTV(DEGREE!-MAP,I,T) >>
  1113. ELSE <<
  1114. FACTOR!-TRACE "Refine an existing degree map";
  1115. DEGREE!-MAP:=PREVIOUS!-DEGREE!-MAP >>;
  1116. DEGREE!-MAP1:=MKVECT DPOLY;
  1117. FOR EACH S IN L DO <<
  1118. % For each degree set S I will collect in DEGREE-MAP1 a
  1119. % bitmap showing what degree factors would be consistent
  1120. % with that set. By ANDing together all these maps
  1121. % (into DEGREE-MAP) I find what degrees for factors are
  1122. % consistent with the whole of the information I have;
  1123. FOR I:=0:DPOLY DO PUTV(DEGREE!-MAP1,I,NIL);
  1124. PUTV(DEGREE!-MAP1,0,T);
  1125. PUTV(DEGREE!-MAP1,DPOLY,T);
  1126. FOR EACH D IN S DO FOR I:=DPOLY#-D#-1 STEP -1 UNTIL 0 DO
  1127. IF GETV(DEGREE!-MAP1,I) THEN
  1128. PUTV(DEGREE!-MAP1,I#+D,T);
  1129. FOR I:=0:DPOLY DO
  1130. PUTV(DEGREE!-MAP,I,GETV(DEGREE!-MAP,I) AND
  1131. GETV(DEGREE!-MAP1,I)) >>;
  1132. FACTOR!-TRACE <<
  1133. PRINTC "Possible degrees for factors are: ";
  1134. FOR I:=1:DPOLY#-1 DO
  1135. IF GETV(DEGREE!-MAP,I) THEN << PRINC I; PRINC " " >>;
  1136. TERPRI() >>;
  1137. I:=DPOLY#-1;
  1138. WHILE I#>0 DO IF GETV(DEGREE!-MAP,I) THEN I:=-1
  1139. ELSE I:=I#-1;
  1140. IF I=0 THEN <<
  1141. FACTOR!-TRACE
  1142. PRINTC "Degree analysis proves polynomial irreducible";
  1143. RETURN IRREDUCIBLE:=T >>;
  1144. FOR EACH S IN L DO IF LENGTH S=TARGET!-COUNT THEN BEGIN
  1145. % Sets with too many factors are not plausible anyway;
  1146. I:=S;
  1147. WHILE I AND GETV(DEGREE!-MAP,CAR I) DO I:=CDR I;
  1148. % If I drop through with I null it was because the set was
  1149. % consistent, otherwise it represented a false split;
  1150. IF NULL I THEN PLAUSIBLE!-SPLIT!-FOUND:=T END;
  1151. PREVIOUS!-DEGREE!-MAP:=DEGREE!-MAP;
  1152. IF PLAUSIBLE!-SPLIT!-FOUND OR ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE
  1153. THEN RETURN NIL;
  1154. % PRINTC "Going to try getting some more images";
  1155. RETURN BAD!-CASE:=T
  1156. END;
  1157. SYMBOLIC PROCEDURE SUM!-LIST L;
  1158. IF NULL CDR L THEN CAR L
  1159. ELSE CAR L #+ SUM!-LIST CDR L;
  1160. ENDMODULE;
  1161. MODULE EZGCD;
  1162. % *******************************************************************
  1163. %
  1164. % copyright (c) university of cambridge, england 1981
  1165. %
  1166. % *******************************************************************;
  1167. % polynomial gcd algorithms;
  1168. %
  1169. % a. c. norman. 1981.
  1170. %
  1171. %
  1172. %**********************************************************************;
  1173. SYMBOLIC PROCEDURE EZGCDF(U,V);
  1174. %entry point for REDUCE call in GCDF;
  1175. BEGIN SCALAR FACTOR!-LEVEL;
  1176. FACTOR!-LEVEL := 0;
  1177. RETURN POLY!-ABS GCDLIST LIST(U,V)
  1178. END;
  1179. %SYMBOLIC PROCEDURE SIMPEZGCD U;
  1180. % calculate the gcd of the polynomials given as arguments;
  1181. % BEGIN
  1182. % SCALAR FACTOR!-LEVEL,W;
  1183. % FACTOR!-LEVEL:=0;
  1184. % U := FOR EACH P IN U COLLECT <<
  1185. % W := SIMP!* P;
  1186. % IF (DENR W NEQ 1) THEN
  1187. % REDERR "EZGCD requires polynomial arguments";
  1188. % NUMR W >>;
  1189. % RETURN (POLY!-ABS GCDLIST U) ./ 1
  1190. % END;
  1191. %PUT('EZGCD,'SIMPFN,'SIMPEZGCD);
  1192. SYMBOLIC PROCEDURE SIMPNPRIMITIVE P;
  1193. % Remove any simple numeric factors from the expression P;
  1194. BEGIN
  1195. SCALAR NP,DP;
  1196. IF ATOM P OR NOT ATOM CDR P THEN
  1197. REDERR "NPRIMITIVE requires just one argument";
  1198. P := SIMP!* CAR P;
  1199. IF POLYZEROP(NUMR P) THEN RETURN NIL ./ 1;
  1200. NP := QUOTFAIL(NUMR P,NUMERIC!-CONTENT NUMR P);
  1201. DP := QUOTFAIL(DENR P,NUMERIC!-CONTENT DENR P);
  1202. RETURN (NP ./ DP)
  1203. END;
  1204. PUT('NPRIMITIVE,'SIMPFN,'SIMPNPRIMITIVE);
  1205. SYMBOLIC PROCEDURE POLY!-GCD(U,V);
  1206. %U and V are standard forms.
  1207. %Value is the gcd of U and V;
  1208. BEGIN SCALAR XEXP,Y,Z;
  1209. IF POLYZEROP U THEN RETURN POLY!-ABS V
  1210. ELSE IF POLYZEROP V THEN RETURN POLY!-ABS U
  1211. ELSE IF U=1 OR V=1 THEN RETURN 1;
  1212. XEXP := !*EXP;
  1213. !*EXP := T;
  1214. % The case of one argument exactly dividing the other is
  1215. % detected specially here because it is perhaps a fairly
  1216. % common circumstance;
  1217. IF QUOTF1(U,V) THEN Z := V
  1218. ELSE IF QUOTF1(V,U) THEN Z := U
  1219. ELSE IF !*GCD THEN Z := GCDLIST LIST(U,V)
  1220. ELSE Z := 1;
  1221. !*EXP := XEXP;
  1222. RETURN POLY!-ABS Z
  1223. END;
  1224. MOVED('GCDF,'POLY!-GCD);
  1225. SYMBOLIC PROCEDURE EZGCD!-COMFAC P;
  1226. %P is a standard form
  1227. %CAR of result is lowest common power of leading kernel in
  1228. %every term in P (or NIL). CDR is gcd of all coefficients of
  1229. %powers of leading kernel;
  1230. IF DOMAINP P THEN NIL . POLY!-ABS P
  1231. ELSE IF NULL RED P THEN LPOW P . POLY!-ABS LC P
  1232. ELSE BEGIN
  1233. SCALAR POWER,COEFLIST,VAR;
  1234. % POWER will be the first part of the answer returned,
  1235. % COEFLIST will collect a list of all coefs in the polynomial
  1236. % P viewed as a poly in its main variable,
  1237. % VAR is the main variable concerned;
  1238. VAR := MVAR P;
  1239. WHILE MVAR P=VAR AND NOT DOMAINP RED P DO <<
  1240. COEFLIST := LC P . COEFLIST;
  1241. P:=RED P >>;
  1242. IF MVAR P=VAR THEN <<
  1243. COEFLIST := LC P . COEFLIST;
  1244. IF NULL RED P THEN POWER := LPOW P
  1245. ELSE COEFLIST := RED P . COEFLIST >>
  1246. ELSE COEFLIST := P . COEFLIST;
  1247. RETURN POWER . GCDLIST COEFLIST
  1248. END;
  1249. GLOBAL '(!*FLOAT);
  1250. SYMBOLIC PROCEDURE GCD!-WITH!-NUMBER(N,A);
  1251. % n is a number, a is a polynomial - return their gcd, given that
  1252. % n is non-zero;
  1253. IF N=1 OR NOT ATOM N OR !*FLOAT THEN 1
  1254. ELSE IF DOMAINP A
  1255. THEN IF A=NIL THEN ABS N
  1256. ELSE IF NOT ATOM A THEN 1
  1257. ELSE GCD(N,A)
  1258. ELSE GCD!-WITH!-NUMBER(GCD!-WITH!-NUMBER(N,LC A),RED A);
  1259. MOVED('GCDFD,'GCD!-WITH!-NUMBER);
  1260. SYMBOLIC PROCEDURE CONTENTS!-WITH!-RESPECT!-TO(P,V);
  1261. IF DOMAINP P THEN NIL . POLY!-ABS P
  1262. ELSE IF MVAR P=V THEN EZGCD!-COMFAC P
  1263. ELSE BEGIN
  1264. SCALAR Y,W;
  1265. Y := SETKORDER LIST V;
  1266. P := REORDER P;
  1267. W := EZGCD!-COMFAC P;
  1268. SETKORDER Y;
  1269. P := REORDER P;
  1270. RETURN REORDER W
  1271. END;
  1272. SYMBOLIC PROCEDURE NUMERIC!-CONTENT FORM;
  1273. % Find numeric content of non-zero polynomial;
  1274. IF DOMAINP FORM THEN ABS FORM
  1275. ELSE IF NULL RED FORM THEN NUMERIC!-CONTENT LC FORM
  1276. ELSE BEGIN
  1277. SCALAR G1;
  1278. G1 := NUMERIC!-CONTENT LC FORM;
  1279. IF NOT (G1=1) THEN G1 := GCD(G1,NUMERIC!-CONTENT RED FORM);
  1280. RETURN G1
  1281. END;
  1282. SYMBOLIC PROCEDURE GCDLIST L;
  1283. % Return the GCD of all the polynomials in the list L.
  1284. %
  1285. % First find all variables mentioned in the polynomials in L,
  1286. % and remove monomial content from them all. If in the process
  1287. % a constant poly is found, take special action. If then there
  1288. % is some variable that is mentioned in all the polys in L, and
  1289. % which occurs only linearly in one of them establish that as
  1290. % main variable and proceed to GCDLIST3 (which will take s
  1291. % a special case exit). Otherwise, if there are any variables that
  1292. % do not occur in all the polys in L they can not occur in the GCD,
  1293. % so take coefficients with respect to them to get a longer list of
  1294. % smaller polynomials - restart. Finally we have a set of polys
  1295. % all involving exactly the same set of variables;
  1296. IF NULL L THEN NIL
  1297. ELSE IF NULL CDR L THEN POLY!-ABS CAR L
  1298. ELSE IF DOMAINP CAR L THEN GCDLD(CDR L,CAR L)
  1299. ELSE BEGIN
  1300. SCALAR L1,GCONT,X;
  1301. % Copy L to L1, but on the way detect any domain elements
  1302. % and deal with them specially;
  1303. WHILE NOT NULL L DO <<
  1304. IF NULL CAR L THEN L := CDR L
  1305. ELSE IF DOMAINP CAR L THEN <<
  1306. L1 := LIST LIST GCDLD(CDR L,GCDLD(MAPCARCAR L1,CAR L));
  1307. L := NIL >>
  1308. ELSE <<
  1309. L1 := (CAR L . POWERS1 CAR L) . L1;
  1310. L := CDR L >> >>;
  1311. IF NULL L1 THEN RETURN NIL
  1312. ELSE IF NULL CDR L1 THEN RETURN POLY!-ABS CAAR L1;
  1313. % Now L1 is a list where each polynomial is paired with information
  1314. % about the powers of variables in it;
  1315. GCONT := NIL; % Compute monomial content on things in L;
  1316. X := NIL; % First time round flag;
  1317. L := FOR EACH P IN L1 COLLECT BEGIN
  1318. SCALAR GCONT1,GCONT2,W;
  1319. % Set GCONT1 to least power information, and W to power
  1320. % difference;
  1321. W := FOR EACH Y IN CDR P
  1322. COLLECT << GCONT1 := (CAR Y . CDDR Y) . GCONT1;
  1323. CAR Y . (CADR Y-CDDR Y) >>;
  1324. % Now get the monomial content as a standard form (in GCONT2);
  1325. GCONT2 := NUMERIC!-CONTENT CAR P;
  1326. IF NULL X THEN << GCONT := GCONT1; X := GCONT2 >>
  1327. ELSE << GCONT := VINTERSECTION(GCONT,GCONT1);
  1328. % Accumulate monomial gcd;
  1329. X := GCD(X,GCONT2) >>;
  1330. FOR EACH Q IN GCONT1 DO IF NOT CDR Q=0 THEN
  1331. GCONT2 := MULTF(GCONT2,!*P2F MKSP(CAR Q,CDR Q));
  1332. RETURN QUOTFAIL1(CAR P,GCONT2,"Term content division failed")
  1333. . W
  1334. END;
  1335. % Here X is the numeric part of the final GCD;
  1336. FOR EACH Q IN GCONT DO X := MULTF(X,!*P2F MKSP(CAR Q,CDR Q));
  1337. TRACE!-TIME <<
  1338. PRIN2!* "Term gcd = ";
  1339. FAC!-PRINTSF X >>;
  1340. RETURN POLY!-ABS MULTF(X,GCDLIST1 L)
  1341. END;
  1342. SYMBOLIC PROCEDURE GCDLIST1 L;
  1343. % Items in L are monomial-primitive, and paired with power information.
  1344. % Find out what variables are common to all polynomials in L and
  1345. % remove all others;
  1346. BEGIN
  1347. SCALAR UNIONV,INTERSECTIONV,VORD,X,L1,REDUCTION!-COUNT;
  1348. UNIONV := INTERSECTIONV := CDAR L;
  1349. FOR EACH P IN CDR L DO <<
  1350. UNIONV := VUNION(UNIONV,CDR P);
  1351. INTERSECTIONV := VINTERSECTION(INTERSECTIONV,CDR P) >>;
  1352. IF NULL INTERSECTIONV THEN RETURN 1;
  1353. FOR EACH V IN INTERSECTIONV DO
  1354. UNIONV := VDELETE(V,UNIONV);
  1355. % Now UNIONV is list of those variables mentioned that
  1356. % are not common to all polynomials;
  1357. INTERSECTIONV := SORT(INTERSECTIONV,FUNCTION LESSPCDR);
  1358. IF CDAR INTERSECTIONV=1 THEN <<
  1359. % I have found something that is linear in one of its variables;
  1360. VORD := MAPCARCAR APPEND(INTERSECTIONV,UNIONV);
  1361. L1 := SETKORDER VORD;
  1362. TRACE!-TIME <<
  1363. PRINC "Selecting "; PRINC CAAR INTERSECTIONV;
  1364. PRINTC " as main because some poly is linear in it" >>;
  1365. X := GCDLIST3(FOR EACH P IN L COLLECT REORDER CAR P,NIL,VORD);
  1366. SETKORDER L1;
  1367. RETURN REORDER X >>
  1368. ELSE IF NULL UNIONV THEN RETURN GCDLIST2(L,INTERSECTIONV);
  1369. TRACE!-TIME <<
  1370. PRINC "The variables "; PRINC UNIONV; PRINTC " can be removed" >>;
  1371. VORD := SETKORDER MAPCARCAR APPEND(UNIONV,INTERSECTIONV);
  1372. L1 := NIL;
  1373. FOR EACH P IN L DO
  1374. L1:=SPLIT!-WRT!-VARIABLES(REORDER CAR P,MAPCARCAR UNIONV,L1);
  1375. SETKORDER VORD;
  1376. RETURN GCDLIST1(FOR EACH P IN L1 COLLECT
  1377. (REORDER P . TOTAL!-DEGREE!-IN!-POWERS(P,NIL)))
  1378. END;
  1379. SYMBOLIC PROCEDURE GCDLIST2(L,VARS);
  1380. % Here all the variables in VARS are used in every polynomial
  1381. % in L. Select a good variable ordering;
  1382. BEGIN
  1383. SCALAR X,X1,GG,LMODP,ONESTEP,VORD,OLDMOD,IMAGE!-SET,GCDPOW,
  1384. UNLUCKY!-CASE;
  1385. % In the univariate case I do not need to think very hard about
  1386. % the selection of a main variable!! ;
  1387. IF NULL CDR VARS
  1388. THEN RETURN GCDLIST3(MAPCARCAR L,NIL,LIST CAAR VARS);
  1389. OLDMOD := SET!-MODULUS NIL;
  1390. % If some variable appears at most to degree two in some pair
  1391. % of the polynomials then that will do as a main variable;
  1392. VARS := MAPCARCAR SORT(VARS,FUNCTION GREATERPCDR);
  1393. % Vars is now arranged with the variable that appears to highest
  1394. % degree anywhere in L first, and the rest in descending order;
  1395. L := FOR EACH P IN L COLLECT CAR P .
  1396. SORT(CDR P,FUNCTION LESSPCDR);
  1397. L := SORT(L,FUNCTION LESSPCDADR);
  1398. % Each list of degree information in L is sorted with lowest degree
  1399. % vars first, and the polynomial with the lowest degree variable
  1400. % of all will come first;
  1401. X := INTERSECTION(DEG2VARS(CDAR L),DEG2VARS(CDADR L));
  1402. IF NOT NULL X THEN <<
  1403. TRACE!-TIME << PRINC "Two inputs are at worst quadratic in ";
  1404. PRINTC CAR X >>;
  1405. GO TO X!-TO!-TOP >>; % Here I have found two polys with a common
  1406. % variable that they are quadratic in;
  1407. % Now generate modular images of the gcd to guess its degree wrt
  1408. % all possible variables;
  1409. % If either (a) modular gcd=1 or (b) modular gcd can be computed with
  1410. % just 1 reduction step, use that information to choose a main variable;
  1411. TRY!-AGAIN: % Modular images may be degenerate;
  1412. SET!-MODULUS RANDOM!-PRIME();
  1413. UNLUCKY!-CASE := NIL;
  1414. IMAGE!-SET := FOR EACH V IN VARS
  1415. COLLECT (V . MODULAR!-NUMBER RANDOM());
  1416. TRACE!-TIME <<
  1417. PRINC "Select variable ordering using P=";
  1418. PRINC CURRENT!-MODULUS;
  1419. PRINC " and substitutions from ";
  1420. PRINTC IMAGE!-SET >>;
  1421. X1 := VARS;
  1422. TRY!-VARS:
  1423. IF NULL X1 THEN GO TO IMAGES!-TRIED;
  1424. LMODP := FOR EACH P IN L COLLECT MAKE!-IMAGE!-MOD!-P(CAR P,CAR X1);
  1425. IF UNLUCKY!-CASE THEN GO TO TRY!-AGAIN;
  1426. LMODP := SORT(LMODP,FUNCTION LESSPDEG);
  1427. GG := GCDLIST!-MOD!-P(CAR LMODP,CDR LMODP);
  1428. IF DOMAINP GG OR (REDUCTION!-COUNT<2 AND (ONESTEP:=T)) THEN <<
  1429. TRACE!-TIME << PRINC "Select "; PRINTC CAR X1 >>;
  1430. X := LIST CAR X1; GO TO X!-TO!-TOP >>;
  1431. GCDPOW := (CAR X1 . LDEG GG) . GCDPOW;
  1432. X1 := CDR X1;
  1433. GO TO TRY!-VARS;
  1434. IMAGES!-TRIED:
  1435. % In default of anything better to do, use image variable such that
  1436. % degree of gcd wrt it is as large as possible;
  1437. VORD := MAPCARCAR SORT(GCDPOW,FUNCTION GREATERPCDR);
  1438. TRACE!-TIME << PRINC "Select order by degrees: ";
  1439. PRINTC GCDPOW >>;
  1440. GO TO ORDER!-CHOSEN;
  1441. X!-TO!-TOP:
  1442. FOR EACH V IN X DO VARS := DELETE(V,VARS);
  1443. VORD := APPEND(X,VARS);
  1444. ORDER!-CHOSEN:
  1445. TRACE!-TIME << PRINC "Selected Var order = "; PRINTC VORD >>;
  1446. SET!-MODULUS OLDMOD;
  1447. VARS := SETKORDER VORD;
  1448. X := GCDLIST3(FOR EACH P IN L COLLECT REORDER CAR P,ONESTEP,VORD);
  1449. SETKORDER VARS;
  1450. RETURN REORDER X
  1451. END;
  1452. SYMBOLIC PROCEDURE GCDLIST!-MOD!-P(GG,L);
  1453. IF NULL L THEN GG
  1454. ELSE IF GG=1 THEN 1
  1455. ELSE GCDLIST!-MOD!-P(GCD!-MOD!-P(GG,CAR L),CDR L);
  1456. SYMBOLIC PROCEDURE DEG2VARS L;
  1457. IF NULL L THEN NIL
  1458. ELSE IF CDAR L>2 THEN NIL
  1459. ELSE CAAR L . DEG2VARS CDR L;
  1460. SYMBOLIC PROCEDURE VDELETE(A,B);
  1461. IF NULL B THEN NIL
  1462. ELSE IF CAR A=CAAR B THEN CDR B
  1463. ELSE CAR B . VDELETE(A,CDR B);
  1464. SYMBOLIC PROCEDURE INTERSECTION(U,V);
  1465. IF NULL U THEN NIL
  1466. ELSE IF MEMBER(CAR U,V) THEN CAR U . INTERSECTION(CDR U,V)
  1467. ELSE INTERSECTION(CDR U,V);
  1468. SYMBOLIC PROCEDURE VINTERSECTION(A,B);
  1469. BEGIN
  1470. SCALAR C;
  1471. RETURN IF NULL A THEN NIL
  1472. ELSE IF NULL (C:=ASSOC(CAAR A,B)) THEN VINTERSECTION(CDR A,B)
  1473. ELSE IF CDAR A>CDR C THEN
  1474. IF CDR C=0 THEN VINTERSECTION(CDR A,B)
  1475. ELSE C . VINTERSECTION(CDR A,B)
  1476. ELSE IF CDAR A=0 THEN VINTERSECTION(CDR A,B)
  1477. ELSE CAR A . VINTERSECTION(CDR A,B)
  1478. END;
  1479. SYMBOLIC PROCEDURE VUNION(A,B);
  1480. BEGIN
  1481. SCALAR C;
  1482. RETURN IF NULL A THEN B
  1483. ELSE IF NULL (C:=ASSOC(CAAR A,B)) THEN CAR A . VUNION(CDR A,B)
  1484. ELSE IF CDAR A>CDR C THEN CAR A . VUNION(CDR A,DELETE(C,B))
  1485. ELSE C . VUNION(CDR A,DELETE(C,B))
  1486. END;
  1487. SYMBOLIC PROCEDURE MAPCARCAR L;
  1488. FOR EACH X IN L COLLECT CAR X;
  1489. SYMBOLIC PROCEDURE GCDLD(L,N);
  1490. % GCD of the domain element N and all the polys in L;
  1491. IF N=1 OR N=-1 THEN 1
  1492. ELSE IF L=NIL THEN ABS N
  1493. ELSE IF CAR L=NIL THEN GCDLD(CDR L,N)
  1494. ELSE GCDLD(CDR L,GCD!-WITH!-NUMBER(N,CAR L));
  1495. SYMBOLIC PROCEDURE SPLIT!-WRT!-VARIABLES(P,VL,L);
  1496. % Push all the coeffs in P wrt variables in VL onto the list L
  1497. % Stop if 1 is found as a coeff;
  1498. IF P=NIL THEN L
  1499. ELSE IF NOT NULL L AND CAR L=1 THEN L
  1500. ELSE IF DOMAINP P THEN ABS P . L
  1501. ELSE IF MEMBER(MVAR P,VL) THEN
  1502. SPLIT!-WRT!-VARIABLES(RED P,VL,SPLIT!-WRT!-VARIABLES(LC P,VL,L))
  1503. ELSE P . L;
  1504. SYMBOLIC PROCEDURE GCDLIST3(L,ONESTEP,VLIST);
  1505. % GCD of the nontrivial polys in the list L given that they all
  1506. % involve all the variables that any of them mention,
  1507. % and they are all monomial-primitive.
  1508. % ONESTEP is true if it is predicted that only one PRS step
  1509. % will be needed to compute the gcd - if so try that PRS step;
  1510. BEGIN
  1511. SCALAR OLD!-MODULUS,PRIME,UNLUCKY!-CASE,IMAGE!-SET,GG,GCONT,
  1512. COFACTOR,ZEROS!-LIST,L1,W,LCG,W1,REDUCED!-DEGREE!-LCLST,P1,P2;
  1513. % Make all the polys primitive;
  1514. L1:=FOR EACH P IN L COLLECT P . EZGCD!-COMFAC P;
  1515. L:=FOR EACH C IN L1 COLLECT
  1516. QUOTFAIL1(CAR C,COMFAC!-TO!-POLY CDR C,
  1517. "Content divison in GCDLIST3 failed");
  1518. % All polys in L are now primitive;
  1519. % Because all polys were monomial-primitive, there should
  1520. % be no power of V to go in the result;
  1521. GCONT:=GCDLIST FOR EACH C IN L1 COLLECT CDDR C;
  1522. IF DOMAINP GCONT THEN IF NOT GCONT=1
  1523. THEN ERRORF "GCONT has numeric part";
  1524. % GCD of contents complete now;
  1525. IF DOMAINP (GG:=CAR (L:=SORT(L,FUNCTION DEGREE!-ORDER))) THEN
  1526. RETURN GCONT;
  1527. % Primitive part of one poly is a constant (must be +/-1);
  1528. IF LDEG GG=1 THEN <<
  1529. % True gcd is either GG or 1;
  1530. IF DIVISION!-TEST(GG,L) THEN RETURN MULTF(POLY!-ABS GG,GCONT)
  1531. ELSE RETURN GCONT >>;
  1532. % All polys are now primitive and nontrivial. Use a modular
  1533. % method to extract GCD;
  1534. IF ONESTEP THEN <<
  1535. % Try to take gcd in just one pseudoremainder step, because some
  1536. % previous modular test suggests it may be possible;
  1537. P1 := POLY!-ABS CAR L; P2 := POLY!-ABS CADR L;
  1538. IF P1=P2 THEN <<
  1539. IF DIVISION!-TEST(P1,CDDR L) THEN RETURN MULTF(P1,GCONT) >>
  1540. ELSE <<
  1541. TRACE!-TIME PRINTC "Just one pseudoremainder step needed?";
  1542. GG := POLY!-GCD(LC P1,LC P2);
  1543. GG := EZGCD!-PP ADDF(MULTF(RED P1,
  1544. QUOTFAIL1(LC P2,GG,
  1545. "Division failure when just one pseudoremainder step needed")),
  1546. MULTF(RED P2,NEGF QUOTFAIL1(LC P1,GG,
  1547. "Division failure when just one pseudoremainder step needed")));
  1548. TRACE!-TIME FAC!-PRINTSF GG;
  1549. IF DIVISION!-TEST(GG,L) THEN RETURN MULTF(GG,GCONT) >>
  1550. >>;
  1551. OLD!-MODULUS:=SET!-MODULUS NIL; %Remember modulus;
  1552. LCG:=FOR EACH POLY IN L COLLECT LC POLY;
  1553. TRACE!-TIME << PRINTC "L.C.S OF L ARE:";
  1554. FOR EACH LCPOLY IN LCG DO FAC!-PRINTSF LCPOLY >>;
  1555. LCG:=GCDLIST LCG;
  1556. TRACE!-TIME << PRIN2!* "LCG (=GCD OF THESE) = ";
  1557. FAC!-PRINTSF LCG >>;
  1558. TRY!-AGAIN:
  1559. UNLUCKY!-CASE:=NIL;
  1560. IMAGE!-SET:=NIL;
  1561. SET!-MODULUS(PRIME:=RANDOM!-PRIME());
  1562. % Produce random univariate modular images of all the
  1563. % polynomials;
  1564. W:=L;
  1565. IF NOT ZEROS!-LIST THEN <<
  1566. IMAGE!-SET:=
  1567. ZEROS!-LIST:=TRY!-MAX!-ZEROS!-FOR!-IMAGE!-SET(W,VLIST);
  1568. TRACE!-TIME << PRINTC IMAGE!-SET;
  1569. PRINC " Zeros-list = ";
  1570. PRINTC ZEROS!-LIST >> >>;
  1571. TRACE!-TIME PRINTC LIST("IMAGE SET",IMAGE!-SET);
  1572. GG:=MAKE!-IMAGE!-MOD!-P(CAR W,CAR VLIST);
  1573. TRACE!-TIME PRINTC LIST("IMAGE SET",IMAGE!-SET," GG",GG);
  1574. IF UNLUCKY!-CASE THEN <<
  1575. TRACE!-TIME << PRINTC "Unlucky case, try again";
  1576. PRINT IMAGE!-SET >>;
  1577. GO TO TRY!-AGAIN >>;
  1578. L1:=LIST(CAR W . GG);
  1579. MAKE!-IMAGES:
  1580. IF NULL (W:=CDR W) THEN GO TO IMAGES!-CREATED!-SUCCESSFULLY;
  1581. L1:=(CAR W . MAKE!-IMAGE!-MOD!-P(CAR W,CAR VLIST)) . L1;
  1582. IF UNLUCKY!-CASE THEN <<
  1583. TRACE!-TIME << PRINTC "UNLUCKY AGAIN...";
  1584. PRINTC L1;
  1585. PRINT IMAGE!-SET >>;
  1586. GO TO TRY!-AGAIN >>;
  1587. GG:=GCD!-MOD!-P(GG,CDAR L1);
  1588. IF DOMAINP GG THEN <<
  1589. SET!-MODULUS OLD!-MODULUS;
  1590. TRACE!-TIME PRINT "Primitive parts are coprime";
  1591. RETURN GCONT >>;
  1592. GO TO MAKE!-IMAGES;
  1593. IMAGES!-CREATED!-SUCCESSFULLY:
  1594. L1:=REVERSEWOC L1; % Put back in order with smallest first;
  1595. % If degree of gcd seems to be same as that of smallest item
  1596. % in input list, that item should be the gcd;
  1597. IF LDEG GG=LDEG CAR L THEN <<
  1598. GG:=POLY!-ABS CAR L;
  1599. TRACE!-TIME <<
  1600. PRIN2!* "Probable GCD = ";
  1601. FAC!-PRINTSF GG >>;
  1602. GO TO RESULT >>
  1603. ELSE IF (LDEG CAR L=ADD1 LDEG GG) AND
  1604. (LDEG CAR L=LDEG CADR L) THEN <<
  1605. % Here it seems that I have just one pseudoremainder step to
  1606. % perform, so I might as well do it;
  1607. TRACE!-TIME <<
  1608. PRINTC "Just one pseudoremainder step needed"
  1609. >>;
  1610. GG := POLY!-GCD(LC CAR L,LC CADR L);
  1611. GG := EZGCD!-PP ADDF(MULTF(RED CAR L,
  1612. QUOTFAIL1(LC CADR L,GG,
  1613. "Division failure when just one pseudoremainder step needed")),
  1614. MULTF(RED CADR L,NEGF QUOTFAIL1(LC CAR L,GG,
  1615. "Divison failure when just one pseudoremainder step needed")));
  1616. TRACE!-TIME FAC!-PRINTSF GG;
  1617. GO TO RESULT >>;
  1618. W:=L1;
  1619. FIND!-GOOD!-COFACTOR:
  1620. IF NULL W THEN GO TO SPECIAL!-CASE; % No good cofactor available;
  1621. IF DOMAINP GCD!-MOD!-P(GG,COFACTOR:=QUOTIENT!-MOD!-P(CDAR W,GG))
  1622. THEN GO TO GOOD!-COFACTOR!-FOUND;
  1623. W:=CDR W;
  1624. GO TO FIND!-GOOD!-COFACTOR;
  1625. GOOD!-COFACTOR!-FOUND:
  1626. COFACTOR:=MONIC!-MOD!-P COFACTOR;
  1627. TRACE!-TIME PRINTC "*** Good cofactor found";
  1628. W:=CAAR W;
  1629. TRACE!-TIME << PRIN2!* "W= ";
  1630. FAC!-PRINTSF W;
  1631. PRIN2!* "GG= ";
  1632. FAC!-PRINTSF GG;
  1633. PRIN2!* "COFACTOR= ";
  1634. FAC!-PRINTSF COFACTOR >>;
  1635. IMAGE!-SET:=SORT(IMAGE!-SET,FUNCTION ORDOPCAR);
  1636. TRACE!-TIME << PRINC "IMAGE-SET = ";
  1637. PRINTC IMAGE!-SET;
  1638. PRINC "PRIME= "; PRINTC PRIME;
  1639. PRINTC "L (=POLYLIST) IS:";
  1640. FOR EACH LL IN L DO FAC!-PRINTSF LL >>;
  1641. GG:=RECONSTRUCT!-GCD(W,GG,COFACTOR,L,PRIME,IMAGE!-SET,LCG);
  1642. IF GG='NOGOOD THEN GOTO TRY!-AGAIN;
  1643. GO TO RESULT;
  1644. SPECIAL!-CASE: % Here I have to do the first step of a PRS method;
  1645. TRACE!-TIME << PRINTC "*** SPECIAL CASE IN GCD ***";
  1646. PRINTC L;
  1647. PRINTC "----->";
  1648. PRINTC GG >>;
  1649. REDUCED!-DEGREE!-LCLST:=NIL;
  1650. TRY!-REDUCED!-DEGREE!-AGAIN:
  1651. TRACE!-TIME << PRINTC "L1 =";
  1652. FOR EACH ELL IN L1 DO PRINT ELL >>;
  1653. W1:=REDUCED!-DEGREE(CAADR L1,CAAR L1);
  1654. W:=CAR W1; W1:=CDR W1;
  1655. TRACE!-TIME << PRINC "REDUCED!-DEGREE = "; FAC!-PRINTSF W;
  1656. PRINC " and its image = "; FAC!-PRINTSF W1 >>;
  1657. % reduce the degree of the 2nd poly using the 1st. Result is
  1658. % a pair : (new poly . image new poly);
  1659. IF DOMAINP W AND NOT NULL W THEN <<
  1660. SET!-MODULUS OLD!-MODULUS; RETURN GCONT >>;
  1661. % we're done as they're coprime;
  1662. IF W AND LDEG W = LDEG GG THEN <<
  1663. GG:=W; GO TO RESULT >>;
  1664. % possible gcd;
  1665. IF NULL W THEN <<
  1666. % the first poly divided the second one;
  1667. L1:=(CAR L1 . CDDR L1); % discard second poly;
  1668. IF NULL CDR L1 THEN <<
  1669. GG := POLY!-ABS CAAR L1;
  1670. GO TO RESULT >>;
  1671. GO TO TRY!-REDUCED!-DEGREE!-AGAIN >>;
  1672. % haven't made progress yet so repeat with new polys;
  1673. IF LDEG W<=LDEG GG THEN <<
  1674. GG := POLY!-ABS W;
  1675. GO TO RESULT >>
  1676. ELSE IF DOMAINP GCD!-MOD!-P(GG,COFACTOR:=QUOTIENT!-MOD!-P(W1,GG))
  1677. THEN <<
  1678. W := LIST LIST W;
  1679. GO TO GOOD!-COFACTOR!-FOUND >>;
  1680. L1:= IF LDEG W <= LDEG CAAR L1 THEN
  1681. ((W . W1) . (CAR L1 . CDDR L1))
  1682. ELSE (CAR L1 . ((W . W1) . CDDR L1));
  1683. % replace first two polys by the reduced poly and the first
  1684. % poly ordering according to degree;
  1685. GO TO TRY!-REDUCED!-DEGREE!-AGAIN;
  1686. % need to repeat as we still haven't found a good cofactor;
  1687. RESULT: % Here GG holds a tentative gcd for the primitive parts of
  1688. % all input polys, and GCONT holds a proper one for the content;
  1689. IF DIVISION!-TEST(GG,L) THEN <<
  1690. SET!-MODULUS OLD!-MODULUS;
  1691. RETURN MULTF(GG,GCONT) >>;
  1692. TRACE!-TIME PRINTC LIST("Trial division by ",GG," failed");
  1693. GO TO TRY!-AGAIN
  1694. END;
  1695. GLOBAL '(KORD!*);
  1696. SYMBOLIC PROCEDURE MAKE!-A!-LIST!-OF!-VARIABLES L;
  1697. BEGIN SCALAR VLIST;
  1698. FOR EACH LL IN L DO VLIST:=VARIABLES!.IN!.FORM(LL,VLIST);
  1699. RETURN MAKE!-ORDER!-CONSISTENT(VLIST,KORD!*)
  1700. END;
  1701. SYMBOLIC PROCEDURE MAKE!-ORDER!-CONSISTENT(L,M);
  1702. % L is a subset of M. Make its order consistent with that
  1703. % of M;
  1704. IF NULL L THEN NIL
  1705. ELSE IF NULL M THEN ERRORF("Variable missing from KORD*")
  1706. ELSE IF CAR M MEMBER L THEN CAR M .
  1707. MAKE!-ORDER!-CONSISTENT(DELETE(CAR M,L),CDR M)
  1708. ELSE MAKE!-ORDER!-CONSISTENT(L,CDR M);
  1709. SYMBOLIC PROCEDURE TRY!-MAX!-ZEROS!-FOR!-IMAGE!-SET(L,VLIST);
  1710. IF NULL VLIST THEN ERROR(0,"VLIST NOT SET IN TRY-MAX-ZEROS-...")
  1711. ELSE BEGIN SCALAR Z;
  1712. Z:=FOR EACH V IN CDR VLIST COLLECT
  1713. IF DOMAINP LC CAR L OR NULL QUOTF(LC CAR L,!*K2F V) THEN
  1714. (V . 0) ELSE (V . MODULAR!-NUMBER RANDOM());
  1715. FOR EACH FF IN CDR L DO
  1716. Z:=FOR EACH W IN Z COLLECT
  1717. IF ZEROP CDR W THEN
  1718. IF DOMAINP LC FF OR NULL QUOTF(LC FF,!*K2F CAR W) THEN W
  1719. ELSE (CAR W . MODULAR!-NUMBER RANDOM())
  1720. ELSE W;
  1721. RETURN Z
  1722. END;
  1723. SYMBOLIC PROCEDURE RECONSTRUCT!-GCD(FULL!-POLY,GG,COFACTOR,POLYLIST,
  1724. P,IMSET,LCG);
  1725. % ... ;
  1726. IF NULL ADDF(FULL!-POLY,NEGF MULTF(GG,COFACTOR)) THEN GG
  1727. ELSE (LAMBDA FACTOR!-LEVEL;
  1728. BEGIN SCALAR NUMBER!-OF!-FACTORS,IMAGE!-FACTORS,
  1729. TRUE!-LEADING!-COEFFTS,MULTIVARIATE!-INPUT!-POLY,
  1730. IRREDUCIBLE,NON!-MONIC,BAD!-CASE,TARGET!-FACTOR!-COUNT,
  1731. MULTIVARIATE!-FACTORS,HENSEL!-GROWTH!-SIZE,ALPHALIST,
  1732. COEFFTS!-VECTORS,BEST!-KNOWN!-FACTORS,PRIME!-BASE,
  1733. M!-IMAGE!-VARIABLE, RECONSTRUCTING!-GCD,FULL!-GCD;
  1734. IF NOT(CURRENT!-MODULUS=P) THEN
  1735. ERRORF("GCDLIST HAS NOT RESTORED THE MODULUS");
  1736. % *WARNING* GCDLIST does not restore the modulus so
  1737. % I had better reset it here! ;
  1738. IF POLY!-MINUSP LCG THEN ERROR(0,LIST("Negative GCD: ",LCG));
  1739. FULL!-POLY:=POLY!-ABS FULL!-POLY;
  1740. INITIALISE!-HENSEL!-FLUIDS(FULL!-POLY,GG,COFACTOR,P,LCG);
  1741. TRACE!-TIME << PRINTC "TRUE LEADING COEFFTS ARE:";
  1742. FOR I:=1:2 DO <<
  1743. FAC!-PRINTSF GETV(IMAGE!-FACTORS,I);
  1744. PRIN2!* " WITH L.C.:";
  1745. FAC!-PRINTSF GETV(TRUE!-LEADING!-COEFFTS,I) >> >>;
  1746. IF DETERMINE!-MORE!-COEFFTS()='DONE THEN
  1747. RETURN FULL!-GCD;
  1748. IF NULL ALPHALIST THEN ALPHALIST:=ALPHAS(2,
  1749. LIST(GETV(IMAGE!-FACTORS,1),GETV(IMAGE!-FACTORS,2)),1);
  1750. IF ALPHALIST='FACTORS! NOT! COPRIME THEN
  1751. ERRORF LIST("image factors not coprime?",IMAGE!-FACTORS);
  1752. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  1753. PRINTSTR
  1754. "The following modular polynomials are chosen such that:";
  1755. TERPRI();
  1756. PRIN2!* " a(2)*f(1) + a(1)*f(2) = 1 mod ";
  1757. PRINTSTR HENSEL!-GROWTH!-SIZE;
  1758. TERPRI();
  1759. PRINTSTR " where degree of a(1) < degree of f(1),";
  1760. PRINTSTR " and degree of a(2) < degree of f(2),";
  1761. PRINTSTR " and";
  1762. FOR I:=1:2 DO <<
  1763. PRIN2!* " a("; PRIN2!* I; PRIN2!* ")=";
  1764. FAC!-PRINTSF CDR GET!-ALPHA GETV(IMAGE!-FACTORS,I);
  1765. PRIN2!* "and f("; PRIN2!* I; PRIN2!* ")=";
  1766. FAC!-PRINTSF GETV(IMAGE!-FACTORS,I);
  1767. TERPRI!* T >>
  1768. >>;
  1769. RECONSTRUCT!-MULTIVARIATE!-FACTORS(
  1770. FOR EACH V IN IMSET COLLECT (CAR V . MODULAR!-NUMBER CDR V));
  1771. IF IRREDUCIBLE OR BAD!-CASE THEN RETURN 'NOGOOD
  1772. ELSE RETURN FULL!-GCD
  1773. END) (FACTOR!-LEVEL+1) ;
  1774. SYMBOLIC PROCEDURE INITIALISE!-HENSEL!-FLUIDS(FPOLY,FAC1,FAC2,P,LCF1);
  1775. % ... ;
  1776. BEGIN SCALAR LC1!-IMAGE,LC2!-IMAGE;
  1777. RECONSTRUCTING!-GCD:=T;
  1778. MULTIVARIATE!-INPUT!-POLY:=MULTF(FPOLY,LCF1);
  1779. PRIME!-BASE:=HENSEL!-GROWTH!-SIZE:=P;
  1780. NUMBER!-OF!-FACTORS:=2;
  1781. LC1!-IMAGE:=MAKE!-NUMERIC!-IMAGE!-MOD!-P LCF1;
  1782. LC2!-IMAGE:=MAKE!-NUMERIC!-IMAGE!-MOD!-P LC FPOLY;
  1783. % Neither of the above leading coefficients will vanish;
  1784. FAC1:=TIMES!-MOD!-P(LC1!-IMAGE,FAC1);
  1785. FAC2:=TIMES!-MOD!-P(LC2!-IMAGE,FAC2);
  1786. IMAGE!-FACTORS:=MKVECT 2;
  1787. TRUE!-LEADING!-COEFFTS:=MKVECT 2;
  1788. PUTV(IMAGE!-FACTORS,1,FAC1);
  1789. PUTV(IMAGE!-FACTORS,2,FAC2);
  1790. PUTV(TRUE!-LEADING!-COEFFTS,1,LCF1);
  1791. PUTV(TRUE!-LEADING!-COEFFTS,2,LC FPOLY);
  1792. % If the GCD is going to be monic, we know the lc
  1793. % of both cofactors exactly;
  1794. NON!-MONIC:=NOT(LCF1=1);
  1795. M!-IMAGE!-VARIABLE:=MVAR FPOLY
  1796. END;
  1797. SYMBOLIC PROCEDURE DIVISION!-TEST(GG,L);
  1798. % Predicate to test if GG divides all the polynomials in the list L;
  1799. IF NULL L THEN T
  1800. ELSE IF NULL QUOTF(CAR L,GG) THEN NIL
  1801. ELSE DIVISION!-TEST(GG,CDR L);
  1802. SYMBOLIC PROCEDURE DEGREE!-ORDER(A,B);
  1803. % Order standard forms using their degrees wrt main vars;
  1804. IF DOMAINP A THEN T
  1805. ELSE IF DOMAINP B THEN NIL
  1806. ELSE LDEG A<LDEG B;
  1807. SYMBOLIC PROCEDURE MAKE!-IMAGE!-MOD!-P(P,V);
  1808. % Form univariate image, set UNLUCKY!-CASE if leading coefficient
  1809. % gets destroyed;
  1810. BEGIN
  1811. SCALAR LP;
  1812. LP := DEGREE!-IN!-VARIABLE(P,V);
  1813. P := MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(P,V);
  1814. IF NOT DEGREE!-IN!-VARIABLE(P,V)=LP THEN UNLUCKY!-CASE := T;
  1815. RETURN P
  1816. END;
  1817. SYMBOLIC PROCEDURE MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(P,V);
  1818. % Make a modular image of P, keeping only the variable V;
  1819. IF DOMAINP P THEN
  1820. IF P=NIL THEN NIL
  1821. ELSE !*N2F MODULAR!-NUMBER P
  1822. ELSE IF MVAR P=V THEN
  1823. ADJOIN!-TERM(LPOW P,
  1824. MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(LC P,V),
  1825. MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(RED P,V))
  1826. ELSE PLUS!-MOD!-P(
  1827. TIMES!-MOD!-P(IMAGE!-OF!-POWER(MVAR P,LDEG P),
  1828. MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(LC P,V)),
  1829. MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(RED P,V));
  1830. SYMBOLIC PROCEDURE IMAGE!-OF!-POWER(V,N);
  1831. BEGIN
  1832. SCALAR W;
  1833. W := ASSOC(V,IMAGE!-SET);
  1834. IF NULL W THEN <<
  1835. W := MODULAR!-NUMBER RANDOM();
  1836. IMAGE!-SET := (V . W) . IMAGE!-SET >>
  1837. ELSE W := CDR W;
  1838. RETURN MODULAR!-EXPT(W,N)
  1839. END;
  1840. SYMBOLIC PROCEDURE MAKE!-NUMERIC!-IMAGE!-MOD!-P P;
  1841. % Make a modular image of P;
  1842. IF DOMAINP P THEN
  1843. IF P=NIL THEN 0
  1844. ELSE MODULAR!-NUMBER P
  1845. ELSE MODULAR!-PLUS(
  1846. MODULAR!-TIMES(IMAGE!-OF!-POWER(MVAR P,LDEG P),
  1847. MAKE!-NUMERIC!-IMAGE!-MOD!-P LC P),
  1848. MAKE!-NUMERIC!-IMAGE!-MOD!-P RED P);
  1849. SYMBOLIC PROCEDURE TOTAL!-DEGREE!-IN!-POWERS(FORM,POWLST);
  1850. % Returns a list where each variable mentioned in FORM is paired
  1851. % with the maximum degree it has. POWLST collects the list, and should
  1852. % normally be NIL on initial entry;
  1853. IF NULL FORM OR DOMAINP FORM THEN POWLST
  1854. ELSE BEGIN SCALAR X;
  1855. IF (X := ATSOC(MVAR FORM,POWLST))
  1856. THEN LDEG FORM>CDR X AND RPLACD(X,LDEG FORM)
  1857. ELSE POWLST := (MVAR FORM . LDEG FORM) . POWLST;
  1858. RETURN TOTAL!-DEGREE!-IN!-POWERS(RED FORM,
  1859. TOTAL!-DEGREE!-IN!-POWERS(LC FORM,POWLST))
  1860. END;
  1861. SYMBOLIC PROCEDURE POWERS1 FORM;
  1862. % For each variable V in FORM collect (V . (MAX . MIN)) where
  1863. % MAX and MIN are limits to the degrees V has in FORM;
  1864. POWERS2(FORM,POWERS3(FORM,NIL),NIL);
  1865. SYMBOLIC PROCEDURE POWERS3(FORM,L);
  1866. % Start of POWERS1 by collecting power information for
  1867. % the leading monomial in FORM;
  1868. IF DOMAINP FORM THEN L
  1869. ELSE POWERS3(LC FORM,(MVAR FORM . (LDEG FORM . LDEG FORM)) . L);
  1870. SYMBOLIC PROCEDURE POWERS2(FORM,POWLST,THISMONOMIAL);
  1871. IF DOMAINP FORM THEN
  1872. IF NULL FORM THEN POWLST ELSE POWERS4(THISMONOMIAL,POWLST)
  1873. ELSE POWERS2(LC FORM,
  1874. POWERS2(RED FORM,POWLST,THISMONOMIAL),
  1875. LPOW FORM . THISMONOMIAL);
  1876. SYMBOLIC PROCEDURE POWERS4(NEW,OLD);
  1877. % Merge information from new monomial into old information,
  1878. % updating MAX and MIN details;
  1879. IF NULL NEW THEN FOR EACH V IN OLD COLLECT (CAR V . (CADR V . 0))
  1880. ELSE IF NULL OLD THEN FOR EACH V IN NEW COLLECT (CAR V . (CDR V . 0))
  1881. ELSE IF CAAR NEW=CAAR OLD THEN <<
  1882. % variables match - do MAX and MIN on degree information;
  1883. IF CDAR NEW>CADAR OLD THEN RPLACA(CDAR OLD,CDAR NEW);
  1884. IF CDAR NEW<CDDAR OLD THEN RPLACD(CDAR OLD,CDAR NEW);
  1885. RPLACD(OLD,POWERS4(CDR NEW,CDR OLD)) >>
  1886. ELSE IF ORDOP(CAAR NEW,CAAR OLD) THEN <<
  1887. RPLACD(CDAR OLD,0); % Some variable not mentioned in new monomial;
  1888. RPLACD(OLD,POWERS4(NEW,CDR OLD)) >>
  1889. ELSE (CAAR NEW . (CDAR NEW . 0)) . POWERS4(CDR NEW,OLD);
  1890. SYMBOLIC PROCEDURE EZGCD!-PP U;
  1891. %returns the primitive part of the polynomial U wrt leading var;
  1892. QUOTF1(U,COMFAC!-TO!-POLY EZGCD!-COMFAC U);
  1893. SYMBOLIC PROCEDURE EZGCD!-SQFRF P;
  1894. %P is a primitive standard form;
  1895. %value is a list of square free factors;
  1896. BEGIN
  1897. SCALAR PDASH,P1,D,V;
  1898. PDASH := DIFF(P,V := MVAR P);
  1899. D := POLY!-GCD(P,PDASH); % p2*p3**2*p4**3*... ;
  1900. IF DOMAINP D THEN RETURN LIST P;
  1901. P := QUOTFAIL1(P,D,"GCD division in FACTOR-SQFRF failed");
  1902. P1 := POLY!-GCD(P,
  1903. ADDF(QUOTFAIL1(PDASH,D,"GCD division in FACTOR-SQFRF failed"),
  1904. NEGF DIFF(P,V)));
  1905. RETURN P1 . EZGCD!-SQFRF D
  1906. END;
  1907. SYMBOLIC PROCEDURE REDUCED!-DEGREE(U,V);
  1908. %U and V are primitive polynomials in the main variable VAR;
  1909. %result is pair: (reduced poly of U by V . its image) where by
  1910. % reduced I mean using V to kill the leading term of U;
  1911. BEGIN SCALAR VAR,W,X;
  1912. TRACE!-TIME << PRINTC "ARGS FOR REDUCED!-DEGREE ARE:";
  1913. FAC!-PRINTSF U; FAC!-PRINTSF V >>;
  1914. IF U=V OR QUOTF1(U,V) THEN RETURN (NIL . NIL)
  1915. ELSE IF LDEG V=1 THEN RETURN (1 . 1);
  1916. TRACE!-TIME PRINTC "CASE NON-TRIVIAL SO TAKE A REDUCED!-DEGREE:";
  1917. VAR := MVAR U;
  1918. IF LDEG U=LDEG V THEN X := NEGF LC U
  1919. ELSE X:=(MKSP(VAR,LDEG U - LDEG V) .* NEGF LC U) .+ NIL;
  1920. W:=ADDF(MULTF(LC V,U),MULTF(X,V));
  1921. TRACE!-TIME FAC!-PRINTSF W;
  1922. IF DEGR(W,VAR)=0 THEN RETURN (1 . 1);
  1923. TRACE!-TIME << PRINC "REDUCED!-DEGREE-LCLST = ";
  1924. PRINT REDUCED!-DEGREE!-LCLST >>;
  1925. REDUCED!-DEGREE!-LCLST := ADDLC(V,REDUCED!-DEGREE!-LCLST);
  1926. TRACE!-TIME << PRINC "REDUCED!-DEGREE-LCLST = ";
  1927. PRINT REDUCED!-DEGREE!-LCLST >>;
  1928. IF X := QUOTF1(W,LC W) THEN W := X
  1929. ELSE FOR EACH Y IN REDUCED!-DEGREE!-LCLST DO
  1930. WHILE (X := QUOTF1(W,Y)) DO W := X;
  1931. U := V; V := EZGCD!-PP W;
  1932. TRACE!-TIME << PRINTC "U AND V ARE NOW:";
  1933. FAC!-PRINTSF U; FAC!-PRINTSF V >>;
  1934. IF DEGR(V,VAR)=0 THEN RETURN (1 . 1)
  1935. ELSE RETURN (V . MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(V,VAR))
  1936. END;
  1937. MOVED('COMFAC,'EZGCD!-COMFAC);
  1938. MOVED('PP,'EZGCD!-PP);
  1939. ENDMODULE;
  1940. MODULE FACMISC;
  1941. % *******************************************************************
  1942. %
  1943. % copyright (c) university of cambridge, england 1979
  1944. %
  1945. % *******************************************************************;
  1946. %**********************************************************************;
  1947. % miscellaneous routines used from several sections ;
  1948. %**********************************************************************;
  1949. % (1) investigate variables in polynomial;
  1950. SYMBOLIC PROCEDURE MULTIVARIATEP(A,V);
  1951. IF DOMAINP A THEN NIL
  1952. ELSE IF NOT(MVAR A EQ V) THEN T
  1953. ELSE IF MULTIVARIATEP(LC A,V) THEN T
  1954. ELSE MULTIVARIATEP(RED A,V);
  1955. SYMBOLIC PROCEDURE VARIABLES!-IN!-FORM A;
  1956. % collect variables that occur in the form a;
  1957. VARIABLES!.IN!.FORM(A,NIL);
  1958. SYMBOLIC PROCEDURE GET!.COEFFT!.BOUND(POLY,DEGBD);
  1959. % calculates a coefft bound for the factors of poly. this simple
  1960. % bound is that suggested by paul wang and linda p. rothschild in
  1961. % math.comp.vol29 july 75 p.940 due to gel'fond;
  1962. % Note that for tiny polynomials the bound is forced up to be
  1963. % larger than any prime that will get used in the mod-p splitting;
  1964. MAX(GET!-HEIGHT POLY * FIXEXPFLOAT SUMOF DEGBD,110);
  1965. SYMBOLIC PROCEDURE SUMOF DEGBD;
  1966. IF NULL DEGBD THEN 0
  1967. ELSE CDAR DEGBD + SUMOF CDR DEGBD;
  1968. SYMBOLIC PROCEDURE FIXEXPFLOAT N;
  1969. % Compute exponential function e**n for potentially large N,
  1970. % rounding result up somewhat. Note that exp(13)=442413 or so,
  1971. % so if the basic floating point exponential function is accurate
  1972. % to 6 or so digits we are protected here against roundoff;
  1973. IF N>13 THEN BEGIN
  1974. SCALAR N2;
  1975. N2 := N/2;
  1976. RETURN FIXEXPFLOAT(N2)*FIXEXPFLOAT(N-N2)
  1977. END
  1978. ELSE 2+FIX EXP FLOAT N;
  1979. % (2) timer services;
  1980. SYMBOLIC PROCEDURE SET!-TIME();
  1981. << LAST!-DISPLAYED!-TIME:=BASE!-TIME:=READTIME();
  1982. LAST!-DISPLAYED!-GC!-TIME:=GC!-BASE!-TIME:=READGCTIME();
  1983. NIL >>;
  1984. GLOBAL '(!*TEST); %not really supported in REDUCE anymore;
  1985. SYMBOLIC PROCEDURE PRINT!-TIME M;
  1986. % display time used so far, with given message;
  1987. BEGIN SCALAR TOTAL,INCR,GCTOTAL,GCINCR,W;
  1988. IF NOT !*TEST THEN RETURN NIL;
  1989. W:=READTIME();
  1990. TOTAL:=W-BASE!-TIME;
  1991. INCR:=W-LAST!-DISPLAYED!-TIME;
  1992. LAST!-DISPLAYED!-TIME:=W;
  1993. W:=READGCTIME();
  1994. GCTOTAL:=W-GC!-BASE!-TIME;
  1995. GCINCR:=W-LAST!-DISPLAYED!-GC!-TIME;
  1996. LAST!-DISPLAYED!-GC!-TIME:=W;
  1997. IF ATOM M THEN PRINC M ELSE <<
  1998. PRINC CAR M;
  1999. M:=CDR M;
  2000. WHILE NOT ATOM M DO << PRINC '! ; PRINC CAR M; M:=CDR M >>;
  2001. IF NOT NULL M THEN << PRINC '! ; PRINC M >> >>;
  2002. PRINC " after ";
  2003. PRINMILLI INCR;
  2004. PRINC "+";
  2005. PRINMILLI GCINCR;
  2006. PRINC " seconds (total = ";
  2007. PRINMILLI TOTAL;
  2008. PRINC "+";
  2009. PRINMILLI GCTOTAL;
  2010. PRINC ")";
  2011. TERPRI()
  2012. END;
  2013. SYMBOLIC PROCEDURE PRINMILLI N;
  2014. % print n/1000 as a decimal fraction with 2 decimal places;
  2015. BEGIN
  2016. SCALAR U,D1,D01;
  2017. N:=N+5; %rounding;
  2018. N:=QUOTIENT(N,10); %now centiseconds;
  2019. N:=DIVIDE(N,10);
  2020. D01:=CDR N;
  2021. N:=CAR N;
  2022. N:=DIVIDE(N,10);
  2023. D1:=CDR N;
  2024. U:=CAR N;
  2025. PRINC U;
  2026. PRINC '!.;
  2027. PRINC D1;
  2028. PRINC D01;
  2029. RETURN NIL
  2030. END;
  2031. % (3) minor variations on ordinary algebraic operations;
  2032. SYMBOLIC PROCEDURE QUOTFAIL(A,B);
  2033. % version of quotf that fails if the division does;
  2034. IF POLYZEROP A THEN POLYZERO
  2035. ELSE BEGIN SCALAR W;
  2036. W:=QUOTF(A,B);
  2037. IF DIDNTGO W THEN ERRORF LIST("UNEXPECTED DIVISION FAILURE",A,B)
  2038. ELSE RETURN W
  2039. END;
  2040. SYMBOLIC PROCEDURE QUOTFAIL1(A,B,MSG);
  2041. % version of quotf that fails if the division does, and gives
  2042. % custom message;
  2043. IF POLYZEROP A THEN POLYZERO
  2044. ELSE BEGIN SCALAR W;
  2045. W:=QUOTF(A,B);
  2046. IF DIDNTGO W THEN ERRORF MSG
  2047. ELSE RETURN W
  2048. END;
  2049. % (4) pseudo-random prime numbers - small and large;
  2050. GLOBAL '(TEENY!-PRIMES);
  2051. SYMBOLIC PROCEDURE SET!-TEENY!-PRIMES();
  2052. BEGIN SCALAR I;
  2053. I:=-1;
  2054. TEENY!-PRIMES:=MKVECT 9;
  2055. PUTV(TEENY!-PRIMES,I:=IADD1 I,3);
  2056. PUTV(TEENY!-PRIMES,I:=IADD1 I,5);
  2057. PUTV(TEENY!-PRIMES,I:=IADD1 I,7);
  2058. PUTV(TEENY!-PRIMES,I:=IADD1 I,11);
  2059. PUTV(TEENY!-PRIMES,I:=IADD1 I,13);
  2060. PUTV(TEENY!-PRIMES,I:=IADD1 I,17);
  2061. PUTV(TEENY!-PRIMES,I:=IADD1 I,19);
  2062. PUTV(TEENY!-PRIMES,I:=IADD1 I,23);
  2063. PUTV(TEENY!-PRIMES,I:=IADD1 I,29);
  2064. PUTV(TEENY!-PRIMES,I:=IADD1 I,31)
  2065. END;
  2066. SET!-TEENY!-PRIMES();
  2067. SYMBOLIC PROCEDURE RANDOM!-SMALL!-PRIME();
  2068. BEGIN
  2069. SCALAR P;
  2070. P:=ILOGOR(1,SMALL!-RANDOM!-NUMBER());
  2071. WHILE NOT PRIMEP P DO
  2072. P:=ILOGOR(1,SMALL!-RANDOM!-NUMBER());
  2073. RETURN P
  2074. END;
  2075. SYMBOLIC PROCEDURE SMALL!-RANDOM!-NUMBER();
  2076. % Returns a number in the range 3 to 103 with a distribution
  2077. % favouring smaller numbers;
  2078. BEGIN
  2079. SCALAR W;
  2080. W:=REMAINDER(RANDOM(),2000);
  2081. W:=TIMES(W,W); % In range 0 to about 4 million;
  2082. RETURN IPLUS(3,W/40000)
  2083. END;
  2084. SYMBOLIC PROCEDURE RANDOM!-TEENY!-PRIME L;
  2085. % get one of the first 10 primes at random providing it is
  2086. % not in the list L or that L says we have tried them all;
  2087. IF L='ALL OR (LENGTH L = 10) THEN NIL
  2088. ELSE BEGIN SCALAR P;
  2089. AGAIN:
  2090. P:=GETV(TEENY!-PRIMES,REMAINDER(RANDOM(),10));
  2091. IF MEMBER(P,L) THEN GOTO AGAIN;
  2092. RETURN P
  2093. END;
  2094. SYMBOLIC PROCEDURE PRIMEP N;
  2095. % Test if prime. Only for use on small integers.
  2096. % Does not consider '2' to be a prime;
  2097. IGREATERP(N,2) AND ILOGAND(N,1)=1 AND PRIMETEST(N,3);
  2098. SYMBOLIC PROCEDURE PRIMETEST(N,TRIAL);
  2099. IF IGREATERP(ITIMES(TRIAL,TRIAL),N) THEN T
  2100. ELSE IF IREMAINDER(N,TRIAL)=0 THEN NIL
  2101. ELSE PRIMETEST(N,IPLUS(TRIAL,2));
  2102. GLOBAL '(BIT1AND23 PSEUDO!-PRIMES);
  2103. BIT1AND23:=LOGOR(1,LEFTSHIFT(1,23));
  2104. FLAG('(BIT1AND23 TWENTYFOURBITS),'CONSTANT);
  2105. % PSEUDO-PRIMES will be a list of all composite numbers which
  2106. % do not have a factor less than 68, and which are in the range
  2107. % 2**23 to 2**24 for which 2**(n-1)=1 mod n;
  2108. PSEUDO!-PRIMES:=MKVECT 121;
  2109. BEGIN
  2110. SCALAR I,L;
  2111. I:=0;
  2112. L:= '( 8534233 8650951 8725753 8727391
  2113. 8745277 8902741 9006401 9037729 9040013
  2114. 9056501 9073513 9131401 9273547 9371251
  2115. 9480461 9533701 9564169 9567673 9588151
  2116. 9591661 9724177 9729301 9774181 9863461
  2117. 10024561 10031653 10084177 10251473 10266001
  2118. 10323769 10331141 10386241 10402237 10403641
  2119. 10425511 10505701 10545991 10610063 10700761
  2120. 10712857 10763653 10802017 10974881 11081459
  2121. 11115037 11335501 11367137 11541307 11585293
  2122. 11592397 11777599 12032021 12096613 12263131
  2123. 12273769 12322133 12327121 12376813 12407011
  2124. 12498061 12599233 12659989 12711007 12854437
  2125. 12932989 13057787 13073941 13295281 13338371
  2126. 13446253 13448593 13500313 13635289 13694761
  2127. 13747361 13773061 13838569 13856417 13991647
  2128. 13996951 14026897 14154337 14179537 14282143
  2129. 14324473 14469841 14589901 14671801 14676481
  2130. 14709241 14794081 14796289 14865121 14899751
  2131. 14980411 15082901 15101893 15139199 15188557
  2132. 15220951 15268501 15479777 15525241 15583153
  2133. 15603391 15621409 15700301 15732721 15757741
  2134. 15802681 15976747 15978007 16070429 16132321
  2135. 16149169 16324001 16349477 16360381 16435747
  2136. 16705021 16717061 16773121);
  2137. WHILE L DO <<
  2138. PUTV(PSEUDO!-PRIMES,I,CAR L);
  2139. I:=I+1;
  2140. L:=CDR L >>
  2141. END;
  2142. SYMBOLIC PROCEDURE RANDOM!-PRIME();
  2143. BEGIN
  2144. SCALAR P,W,OLDMOD;
  2145. IF TWENTYFOURBITS>LARGEST!-SMALL!-MODULUS THEN <<
  2146. REPEAT
  2147. P := LOGOR(1,REMAINDER(RANDOM(),LARGEST!-SMALL!-MODULUS - 1))
  2148. UNTIL P*P>LARGEST!-SMALL!-MODULUS AND PRIMEP P;
  2149. RETURN P >>;
  2150. % W will become 1 when P is prime;
  2151. OLDMOD := CURRENT!-MODULUS;
  2152. WHILE NOT (W=1) DO <<
  2153. % OR in bits 1 and 2**23 to make number odd and large;
  2154. P:=LOGOR(BIT1AND23,LOGAND(TWENTYFOURBITS,RANDOM()));
  2155. % A random (odd) 24 bit integer;
  2156. IF IREMAINDER(P,3)=0 OR IREMAINDER(P,5)=0 OR
  2157. IREMAINDER(P,7)=0 OR IREMAINDER(P,11)=0 OR
  2158. IREMAINDER(P,13)=0 OR IREMAINDER(P,17)=0 OR
  2159. IREMAINDER(P,19)=0 OR IREMAINDER(P,23)=0 OR
  2160. IREMAINDER(P,29)=0 OR IREMAINDER(P,31)=0 OR
  2161. IREMAINDER(P,37)=0 OR IREMAINDER(P,41)=0 OR
  2162. IREMAINDER(P,43)=0 OR IREMAINDER(P,47)=0 OR
  2163. IREMAINDER(P,53)=0 OR IREMAINDER(P,59)=0 OR
  2164. IREMAINDER(P,61)=0 OR IREMAINDER(P,67)=0 THEN W:=0
  2165. ELSE <<
  2166. SET!-MODULUS P;
  2167. W:=MODULAR!-EXPT(2,ISUB1 P);
  2168. IF W=1 AND PSEUDO!-PRIME!-P P THEN W:=0 >> >>;
  2169. SET!-MODULUS OLDMOD;
  2170. RETURN P
  2171. END;
  2172. SYMBOLIC PROCEDURE PSEUDO!-PRIME!-P N;
  2173. BEGIN
  2174. SCALAR LOW,MID,HIGH,V;
  2175. LOW:=0;
  2176. HIGH:=121; % Size of vector of pseudo-primes;
  2177. WHILE NOT (HIGH=LOW) DO << % Binary search in table;
  2178. MID:=IRIGHTSHIFT(IPLUS(IADD1 HIGH,LOW),1);
  2179. % Mid point of (low,high);
  2180. V:=GETV(PSEUDO!-PRIMES,MID);
  2181. IF IGREATERP(V,N) THEN HIGH:=ISUB1 MID ELSE LOW:=MID >>;
  2182. RETURN (GETV(PSEUDO!-PRIMES,LOW)=N)
  2183. END;
  2184. % (5) usefull routines for vectors;
  2185. SYMBOLIC PROCEDURE FORM!-SUM!-AND!-PRODUCT!-MOD!-P(AVEC,FVEC,R);
  2186. % sum over i (avec(i) * fvec(i));
  2187. BEGIN SCALAR S;
  2188. S:=POLYZERO;
  2189. FOR I:=1:R DO
  2190. S:=PLUS!-MOD!-P(TIMES!-MOD!-P(GETV(AVEC,I),GETV(FVEC,I)),
  2191. S);
  2192. RETURN S
  2193. END;
  2194. SYMBOLIC PROCEDURE FORM!-SUM!-AND!-PRODUCT!-MOD!-M(AVEC,FVEC,R);
  2195. % Same as above but AVEC holds alphas mod p and want to work
  2196. % mod m (m > p) so minor difference to change AVEC to AVEC mod m;
  2197. BEGIN SCALAR S;
  2198. S:=POLYZERO;
  2199. FOR I:=1:R DO
  2200. S:=PLUS!-MOD!-P(TIMES!-MOD!-P(
  2201. !*F2MOD !*MOD2F GETV(AVEC,I),GETV(FVEC,I)),S);
  2202. RETURN S
  2203. END;
  2204. SYMBOLIC PROCEDURE REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(V,PT,N);
  2205. % substitute for the given variable in all elements creating a
  2206. % new vector for the result. (all arithmetic is mod p);
  2207. BEGIN SCALAR NEWV;
  2208. NEWV:=MKVECT N;
  2209. FOR I:=1:N DO
  2210. PUTV(NEWV,I,EVALUATE!-MOD!-P(GETV(V,I),CAR PT,CDR PT));
  2211. RETURN NEWV
  2212. END;
  2213. SYMBOLIC PROCEDURE MAKE!-BIVARIATE!-VEC!-MOD!-P(V,IMSET,VAR,N);
  2214. BEGIN SCALAR NEWV;
  2215. NEWV:=MKVECT N;
  2216. FOR I:=1:N DO
  2217. PUTV(NEWV,I,MAKE!-BIVARIATE!-MOD!-P(GETV(V,I),IMSET,VAR));
  2218. RETURN NEWV
  2219. END;
  2220. SYMBOLIC PROCEDURE TIMES!-VECTOR!-MOD!-P(V,N);
  2221. % product of all the elements in the vector mod p;
  2222. BEGIN SCALAR W;
  2223. W:=1;
  2224. FOR I:=1:N DO W:=TIMES!-MOD!-P(GETV(V,I),W);
  2225. RETURN W
  2226. END;
  2227. SYMBOLIC PROCEDURE MAKE!-VEC!-MODULAR!-SYMMETRIC(V,N);
  2228. % fold each elt of V which is current a modular poly in the
  2229. % range 0->(p-1) onto the symmetric range (-p/2)->(p/2);
  2230. FOR I:=1:N DO PUTV(V,I,MAKE!-MODULAR!-SYMMETRIC GETV(V,I));
  2231. % (6) Combinatorial fns used in finding values for the variables;
  2232. SYMBOLIC PROCEDURE MAKE!-ZEROVARSET VLIST;
  2233. % vlist is a list of pairs (v . tag) where v is a variable name and
  2234. % tag is a boolean tag. The procedure splits the list into two
  2235. % according to the tags: Zerovarset is set to a list of variables
  2236. % whose tag is false and othervars contains the rest;
  2237. FOR EACH W IN VLIST DO
  2238. IF CDR W THEN OTHERVARS:= CAR W . OTHERVARS
  2239. ELSE ZEROVARSET:= CAR W . ZEROVARSET;
  2240. SYMBOLIC PROCEDURE MAKE!-ZEROSET!-LIST N;
  2241. % Produces a list of lists each of length n with all combinations of
  2242. % ones and zeroes;
  2243. BEGIN SCALAR W;
  2244. FOR K:=0:N DO W:=APPEND(W,KCOMBNS(K,N));
  2245. RETURN W
  2246. END;
  2247. SYMBOLIC PROCEDURE KCOMBNS(K,M);
  2248. % produces a list of all combinations of ones and zeroes with k ones
  2249. % in each;
  2250. IF K=0 OR K=M THEN BEGIN SCALAR W;
  2251. IF K=M THEN K:=1;
  2252. FOR I:=1:M DO W:=K.W;
  2253. RETURN LIST W
  2254. END
  2255. ELSE IF K=1 OR K=ISUB1 M THEN <<
  2256. IF K=ISUB1 M THEN K:=0;
  2257. LIST!-WITH!-ONE!-A(K,1 #- K,M) >>
  2258. ELSE APPEND(
  2259. FOR EACH X IN KCOMBNS(ISUB1 K,ISUB1 M) COLLECT (1 . X),
  2260. FOR EACH X IN KCOMBNS(K,ISUB1 M) COLLECT (0 . X) );
  2261. SYMBOLIC PROCEDURE LIST!-WITH!-ONE!-A(A,B,M);
  2262. % Creates list of all lists with one a and m-1 b's in;
  2263. BEGIN SCALAR W,X,R;
  2264. FOR I:=1:ISUB1 M DO W:=B . W;
  2265. R:=LIST(A . W);
  2266. FOR I:=1:ISUB1 M DO <<
  2267. X:=(CAR W) . X; W:=CDR W;
  2268. R:=APPEND(X,(A . W)) . R >>;
  2269. RETURN R
  2270. END;
  2271. SYMBOLIC PROCEDURE MAKE!-NEXT!-ZSET L;
  2272. BEGIN SCALAR K,W;
  2273. IMAGE!-SET!-MODULUS:=IADD1 IMAGE!-SET!-MODULUS;
  2274. SET!-MODULUS IMAGE!-SET!-MODULUS;
  2275. W:=FOR EACH LL IN CDR L COLLECT
  2276. FOR EACH N IN LL COLLECT
  2277. IF N=0 THEN N
  2278. ELSE <<
  2279. K:=MODULAR!-NUMBER RANDOM();
  2280. WHILE (ZEROP K) OR (ONEP K) DO
  2281. K:=MODULAR!-NUMBER RANDOM();
  2282. IF K>MODULUS!/2 THEN K:=K-CURRENT!-MODULUS;
  2283. K >>;
  2284. SAVE!-ZSET:=NIL;
  2285. RETURN W
  2286. END;
  2287. ENDMODULE;
  2288. MODULE FACMOD;
  2289. %**********************************************************************;
  2290. %
  2291. % copyright (c) university of cambridge, england 1979
  2292. %
  2293. %**********************************************************************;
  2294. %**********************************************************************;
  2295. %
  2296. % modular factorization section
  2297. %;
  2298. %**********************************************************************;
  2299. % modular factorization : discover the factor count mod p;
  2300. SAFE!-FLAG:=CARCHECK 0; % For speed of array access - important here;
  2301. SYMBOLIC PROCEDURE GET!-FACTOR!-COUNT!-MOD!-P
  2302. (N,POLY!-MOD!-P,P,X!-IS!-FACTOR);
  2303. % gets the factor count mod p from the nth image using the
  2304. % first half of Berlekamp's method;
  2305. BEGIN SCALAR OLD!-M,F!-COUNT,WTIME;
  2306. OLD!-M:=SET!-MODULUS P;
  2307. % PRINC "prime = ";% PRINTC CURRENT!-MODULUS;
  2308. % PRINC "degree = ";% PRINTC LDEG POLY!-MOD!-P;
  2309. TRACE!-TIME DISPLAY!-TIME("Entered GET-FACTOR-COUNT after ",TIME());
  2310. WTIME:=TIME();
  2311. F!-COUNT:=MODULAR!-FACTOR!-COUNT();
  2312. TRACE!-TIME DISPLAY!-TIME("Factor count obtained in ",TIME()-WTIME);
  2313. SPLIT!-LIST:=
  2314. ((IF X!-IS!-FACTOR THEN CAR F!-COUNT#+1 ELSE CAR F!-COUNT) . N)
  2315. . SPLIT!-LIST;
  2316. PUTV(MODULAR!-INFO,N,CDR F!-COUNT);
  2317. SET!-MODULUS OLD!-M
  2318. END;
  2319. SYMBOLIC PROCEDURE MODULAR!-FACTOR!-COUNT();
  2320. BEGIN
  2321. SCALAR POLY!-VECTOR,WVEC1,WVEC2,X!-TO!-P,
  2322. N,WTIME,W,LIN!-F!-COUNT,NULL!-SPACE!-BASIS;
  2323. KNOWN!-FACTORS:=NIL;
  2324. DPOLY:=LDEG POLY!-MOD!-P;
  2325. WVEC1:=MKVECT (2#*DPOLY);
  2326. WVEC2:=MKVECT (2#*DPOLY);
  2327. X!-TO!-P:=MKVECT DPOLY;
  2328. POLY!-VECTOR:=MKVECT DPOLY;
  2329. FOR I:=0:DPOLY DO PUTV(POLY!-VECTOR,I,0);
  2330. POLY!-TO!-VECTOR POLY!-MOD!-P;
  2331. W:=COUNT!-LINEAR!-FACTORS!-MOD!-P(WVEC1,WVEC2,X!-TO!-P);
  2332. LIN!-F!-COUNT:=CAR W;
  2333. IF DPOLY#<4 THEN RETURN
  2334. (IF DPOLY=0 THEN LIN!-F!-COUNT
  2335. ELSE LIN!-F!-COUNT#+1) .
  2336. LIST(LIN!-F!-COUNT . CADR W,
  2337. DPOLY . POLY!-VECTOR,
  2338. NIL);
  2339. % When I use Berlekamp I certainly know that the polynomial
  2340. % involved has no linear factors;
  2341. WTIME:=TIME();
  2342. NULL!-SPACE!-BASIS:=USE!-BERLEKAMP(X!-TO!-P,CADDR W,WVEC1);
  2343. TRACE!-TIME DISPLAY!-TIME("Berlekamp done in ",TIME()-WTIME);
  2344. N:=LIN!-F!-COUNT #+ LENGTH NULL!-SPACE!-BASIS #+ 1;
  2345. % there is always 1 more factor than the number of
  2346. % null vectors we have picked up;
  2347. RETURN N . LIST(
  2348. LIN!-F!-COUNT . CADR W,
  2349. DPOLY . POLY!-VECTOR,
  2350. NULL!-SPACE!-BASIS)
  2351. END;
  2352. %**********************************************************************;
  2353. % Extraction of linear factors is done specially;
  2354. SYMBOLIC PROCEDURE COUNT!-LINEAR!-FACTORS!-MOD!-P(WVEC1,WVEC2,X!-TO!-P);
  2355. % Compute gcd(x**p-x,u). It will be the product of all the
  2356. % linear factors of u mod p;
  2357. BEGIN SCALAR DX!-TO!-P,LIN!-F!-COUNT,LINEAR!-FACTORS;
  2358. FOR I:=0:DPOLY DO PUTV(WVEC2,I,GETV(POLY!-VECTOR,I));
  2359. DX!-TO!-P:=MAKE!-X!-TO!-P(CURRENT!-MODULUS,WVEC1,X!-TO!-P);
  2360. FOR I:=0:DX!-TO!-P DO PUTV(WVEC1,I,GETV(X!-TO!-P,I));
  2361. IF DX!-TO!-P#<1 THEN <<
  2362. IF DX!-TO!-P#<0 THEN PUTV(WVEC1,0,0);
  2363. PUTV(WVEC1,1,MODULAR!-MINUS 1);
  2364. DX!-TO!-P:=1 >>
  2365. ELSE <<
  2366. PUTV(WVEC1,1,MODULAR!-DIFFERENCE(GETV(WVEC1,1),1));
  2367. IF DX!-TO!-P=1 AND GETV(WVEC1,1)=0 THEN
  2368. IF GETV(WVEC1,0)=0 THEN DX!-TO!-P:=-1
  2369. ELSE DX!-TO!-P:=0 >>;
  2370. IF DX!-TO!-P#<0 THEN
  2371. LIN!-F!-COUNT:=COPY!-VECTOR(WVEC2,DPOLY,WVEC1)
  2372. ELSE LIN!-F!-COUNT:=GCD!-IN!-VECTOR(WVEC1,DX!-TO!-P,
  2373. WVEC2,DPOLY);
  2374. LINEAR!-FACTORS:=MKVECT LIN!-F!-COUNT;
  2375. FOR I:=0:LIN!-F!-COUNT DO
  2376. PUTV(LINEAR!-FACTORS,I,GETV(WVEC1,I));
  2377. DPOLY:=QUOTFAIL!-IN!-VECTOR(POLY!-VECTOR,DPOLY,
  2378. LINEAR!-FACTORS,LIN!-F!-COUNT);
  2379. RETURN LIST(LIN!-F!-COUNT,LINEAR!-FACTORS,DX!-TO!-P)
  2380. END;
  2381. SYMBOLIC PROCEDURE MAKE!-X!-TO!-P(P,WVEC1,X!-TO!-P);
  2382. BEGIN SCALAR DX!-TO!-P,DW1;
  2383. IF P#<DPOLY THEN <<
  2384. FOR I:=0:P#-1 DO PUTV(X!-TO!-P,I,0);
  2385. PUTV(X!-TO!-P,P,1);
  2386. RETURN P >>;
  2387. DX!-TO!-P:=MAKE!-X!-TO!-P(P/2,WVEC1,X!-TO!-P);
  2388. DW1:=TIMES!-IN!-VECTOR(X!-TO!-P,DX!-TO!-P,X!-TO!-P,DX!-TO!-P,WVEC1);
  2389. DW1:=REMAINDER!-IN!-VECTOR(WVEC1,DW1,
  2390. POLY!-VECTOR,DPOLY);
  2391. IF NOT(IREMAINDER(P,2)=0) THEN <<
  2392. FOR I:=DW1 STEP -1 UNTIL 0 DO
  2393. PUTV(WVEC1,I#+1,GETV(WVEC1,I));
  2394. PUTV(WVEC1,0,0);
  2395. DW1:=REMAINDER!-IN!-VECTOR(WVEC1,DW1#+1,
  2396. POLY!-VECTOR,DPOLY) >>;
  2397. FOR I:=0:DW1 DO PUTV(X!-TO!-P,I,GETV(WVEC1,I));
  2398. RETURN DW1
  2399. END;
  2400. SYMBOLIC PROCEDURE FIND!-LINEAR!-FACTORS!-MOD!-P(P,N);
  2401. % P is a vector representing a polynomial of degree N which has
  2402. % only linear factors. Find all the factors and return a list of
  2403. % them;
  2404. BEGIN
  2405. SCALAR ROOT,VAR,W,VEC1;
  2406. IF N#<1 THEN RETURN NIL;
  2407. VEC1:=MKVECT 1;
  2408. PUTV(VEC1,1,1);
  2409. ROOT:=0;
  2410. WHILE (N#>1) AND NOT (ROOT #> CURRENT!-MODULUS) DO <<
  2411. W:=EVALUATE!-IN!-VECTOR(P,N,ROOT);
  2412. IF W=0 THEN << %a factor has been found!!;
  2413. IF VAR=NIL THEN
  2414. VAR:=MKSP(M!-IMAGE!-VARIABLE,1) . 1;
  2415. W:=!*F2MOD
  2416. ADJOIN!-TERM(CAR VAR,CDR VAR,!*N2F MODULAR!-MINUS ROOT);
  2417. KNOWN!-FACTORS:=W . KNOWN!-FACTORS;
  2418. PUTV(VEC1,0,MODULAR!-MINUS ROOT);
  2419. N:=QUOTFAIL!-IN!-VECTOR(P,N,VEC1,1) >>;
  2420. ROOT:=ROOT#+1 >>;
  2421. KNOWN!-FACTORS:=
  2422. VECTOR!-TO!-POLY(P,N,M!-IMAGE!-VARIABLE) . KNOWN!-FACTORS
  2423. END;
  2424. %**********************************************************************;
  2425. % Berlekamp's algorithm part 1: find null space basis giving factor
  2426. % count;
  2427. SYMBOLIC PROCEDURE USE!-BERLEKAMP(X!-TO!-P,DX!-TO!-P,WVEC1);
  2428. % Set up a basis for the set of remaining (nonlinear) factors
  2429. % using Berlekamp's algorithm;
  2430. BEGIN
  2431. SCALAR BERL!-M,BERL!-M!-SIZE,W,
  2432. DCURRENT,CURRENT!-POWER,WTIME;
  2433. BERL!-M!-SIZE:=DPOLY#-1;
  2434. BERL!-M:=MKVECT BERL!-M!-SIZE;
  2435. FOR I:=0:BERL!-M!-SIZE DO <<
  2436. W:=MKVECT BERL!-M!-SIZE;
  2437. FOR J:=0:BERL!-M!-SIZE DO PUTV(W,J,0); %initialize to zero;
  2438. PUTV(BERL!-M,I,W) >>;
  2439. % Note that column zero of the matrix (as used in the
  2440. % standard version of Berlekamp's algorithm) is not in fact
  2441. % needed and is not used here;
  2442. % I want to set up a matrix that has entries
  2443. % x**p, x**(2*p), ... , x**((n-1)*p)
  2444. % as its columns,
  2445. % where n is the degree of poly-mod-p
  2446. % and all the entries are reduced mod poly-mod-p;
  2447. % Since I computed x**p I have taken out some linear factors,
  2448. % so reduce it further;
  2449. DX!-TO!-P:=REMAINDER!-IN!-VECTOR(X!-TO!-P,DX!-TO!-P,
  2450. POLY!-VECTOR,DPOLY);
  2451. DCURRENT:=0;
  2452. CURRENT!-POWER:=MKVECT BERL!-M!-SIZE;
  2453. PUTV(CURRENT!-POWER,0,1);
  2454. FOR I:=1:BERL!-M!-SIZE DO <<
  2455. IF CURRENT!-MODULUS#>DPOLY THEN
  2456. DCURRENT:=TIMES!-IN!-VECTOR(
  2457. CURRENT!-POWER,DCURRENT,
  2458. X!-TO!-P,DX!-TO!-P,
  2459. WVEC1)
  2460. ELSE << % Multiply by shifting;
  2461. FOR I:=0:CURRENT!-MODULUS#-1 DO
  2462. PUTV(WVEC1,I,0);
  2463. FOR I:=0:DCURRENT DO
  2464. PUTV(WVEC1,CURRENT!-MODULUS#+I,
  2465. GETV(CURRENT!-POWER,I));
  2466. DCURRENT:=DCURRENT#+CURRENT!-MODULUS >>;
  2467. DCURRENT:=REMAINDER!-IN!-VECTOR(
  2468. WVEC1,DCURRENT,
  2469. POLY!-VECTOR,DPOLY);
  2470. FOR J:=0:DCURRENT DO
  2471. PUTV(GETV(BERL!-M,J),I,PUTV(CURRENT!-POWER,J,
  2472. GETV(WVEC1,J)));
  2473. % also I need to subtract 1 from the diagonal of the matrix;
  2474. PUTV(GETV(BERL!-M,I),I,
  2475. MODULAR!-DIFFERENCE(GETV(GETV(BERL!-M,I),I),1)) >>;
  2476. WTIME:=TIME();
  2477. % PRINT!-M("Q matrix",BERL!-M,BERL!-M!-SIZE);
  2478. W := FIND!-NULL!-SPACE(BERL!-M,BERL!-M!-SIZE);
  2479. TRACE!-TIME DISPLAY!-TIME("Null space found in ",TIME()-WTIME);
  2480. RETURN W
  2481. END;
  2482. SYMBOLIC PROCEDURE FIND!-NULL!-SPACE(BERL!-M,BERL!-M!-SIZE);
  2483. % Diagonalize the matrix to find its rank and hence the number of
  2484. % factors the input polynomial had;
  2485. BEGIN SCALAR NULL!-SPACE!-BASIS;
  2486. % find a basis for the null-space of the matrix;
  2487. FOR I:=1:BERL!-M!-SIZE DO
  2488. NULL!-SPACE!-BASIS:=
  2489. CLEAR!-COLUMN(I,NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE);
  2490. % PRINT!-M("Null vectored",BERL!-M,BERL!-M!-SIZE);
  2491. RETURN
  2492. TIDY!-UP!-NULL!-VECTORS(NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE)
  2493. END;
  2494. SYMBOLIC PROCEDURE PRINT!-M(M,BERL!-M,BERL!-M!-SIZE);
  2495. << PRINTC M;
  2496. FOR I:=0:BERL!-M!-SIZE DO <<
  2497. FOR J:=0:BERL!-M!-SIZE DO <<
  2498. PRINC GETV(GETV(BERL!-M,I),J);
  2499. TTAB((4#*J)#+4) >>;
  2500. TERPRI() >> >>;
  2501. SYMBOLIC PROCEDURE CLEAR!-COLUMN(I,
  2502. NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE);
  2503. % Process column I of the matrix so that (if possible) it
  2504. % just has a '1' in row I and zeros elsewhere;
  2505. BEGIN
  2506. SCALAR II,W;
  2507. % I want to bring a non-zero pivot to the position (i,i)
  2508. % and then add multiples of row i to all other rows to make
  2509. % all but the i'th element of column i zero. First look for
  2510. % a suitable pivot;
  2511. II:=0;
  2512. SEARCH!-FOR!-PIVOT:
  2513. IF GETV(GETV(BERL!-M,II),I)=0 OR
  2514. ((II#<I) AND NOT(GETV(GETV(BERL!-M,II),II)=0)) THEN
  2515. IF (II:=II#+1)#>BERL!-M!-SIZE THEN
  2516. RETURN (I . NULL!-SPACE!-BASIS)
  2517. ELSE GO TO SEARCH!-FOR!-PIVOT;
  2518. % Here ii references a row containing a suitable pivot element for
  2519. % column i. Permute rows in the matrix so as to bring the pivot onto
  2520. % the diagonal;
  2521. W:=GETV(BERL!-M,II);
  2522. PUTV(BERL!-M,II,GETV(BERL!-M,I));
  2523. PUTV(BERL!-M,I,W);
  2524. % swop rows ii and i ;
  2525. W:=MODULAR!-MINUS MODULAR!-RECIPROCAL GETV(GETV(BERL!-M,I),I);
  2526. % w = -1/pivot, and is used in zeroing out the rest of column i;
  2527. FOR ROW:=0:BERL!-M!-SIZE DO
  2528. IF ROW NEQ I THEN BEGIN
  2529. SCALAR R; %process one row;
  2530. R:=GETV(GETV(BERL!-M,ROW),I);
  2531. IF NOT(R=0) THEN <<
  2532. R:=MODULAR!-TIMES(R,W);
  2533. %that is now the multiple of row i that must be added to row ii;
  2534. FOR COL:=I:BERL!-M!-SIZE DO
  2535. PUTV(GETV(BERL!-M,ROW),COL,
  2536. MODULAR!-PLUS(GETV(GETV(BERL!-M,ROW),COL),
  2537. MODULAR!-TIMES(R,GETV(GETV(BERL!-M,I),COL)))) >>
  2538. END;
  2539. FOR COL:=I:BERL!-M!-SIZE DO
  2540. PUTV(GETV(BERL!-M,I),COL,
  2541. MODULAR!-TIMES(GETV(GETV(BERL!-M,I),COL),W));
  2542. RETURN NULL!-SPACE!-BASIS
  2543. END;
  2544. SYMBOLIC PROCEDURE TIDY!-UP!-NULL!-VECTORS(NULL!-SPACE!-BASIS,
  2545. BERL!-M,BERL!-M!-SIZE);
  2546. BEGIN
  2547. SCALAR ROW!-TO!-USE;
  2548. ROW!-TO!-USE:=BERL!-M!-SIZE#+1;
  2549. NULL!-SPACE!-BASIS:=
  2550. FOR EACH NULL!-VECTOR IN NULL!-SPACE!-BASIS COLLECT
  2551. BUILD!-NULL!-VECTOR(NULL!-VECTOR,
  2552. GETV(BERL!-M,ROW!-TO!-USE:=ROW!-TO!-USE#-1),BERL!-M);
  2553. BERL!-M:=NIL; % Release the store for full matrix;
  2554. % PRINC "Null vectors: ";
  2555. % PRINT NULL!-SPACE!-BASIS;
  2556. RETURN NULL!-SPACE!-BASIS
  2557. END;
  2558. SYMBOLIC PROCEDURE BUILD!-NULL!-VECTOR(N,VEC,BERL!-M);
  2559. % At the end of the elimination process (the CLEAR-COLUMN loop)
  2560. % certain columns, indicated by the entries in NULL-SPACE-BASIS
  2561. % will be null vectors, save for the fact that they need a '1'
  2562. % inserted on the diagonal of the matrix. This procedure copies
  2563. % these null-vectors into some of the vectors that represented
  2564. % rows of the Berlekamp matrix;
  2565. BEGIN
  2566. % PUTV(VEC,0,0); % Not used later!!;
  2567. FOR I:=1:N#-1 DO
  2568. PUTV(VEC,I,GETV(GETV(BERL!-M,I),N));
  2569. PUTV(VEC,N,1);
  2570. % FOR I:=N#+1:BERL!-M!-SIZE DO
  2571. % PUTV(VEC,I,0);
  2572. RETURN VEC . N
  2573. END;
  2574. %**********************************************************************;
  2575. % Berlekamp's algorithm part 2: retrieving the factors mod p;
  2576. SYMBOLIC PROCEDURE GET!-FACTORS!-MOD!-P(N,P);
  2577. % given the modular info (for the nth image) generated by the
  2578. % previous half of Berlekamp's method we can reconstruct the
  2579. % actual factors mod p;
  2580. BEGIN SCALAR NTH!-MODULAR!-INFO,OLD!-M,WTIME;
  2581. NTH!-MODULAR!-INFO:=GETV(MODULAR!-INFO,N);
  2582. OLD!-M:=SET!-MODULUS P;
  2583. WTIME:=TIME();
  2584. PUTV(MODULAR!-INFO,N,
  2585. CONVERT!-NULL!-VECTORS!-TO!-FACTORS NTH!-MODULAR!-INFO);
  2586. TRACE!-TIME DISPLAY!-TIME("Factors constructed in ",TIME()-WTIME);
  2587. SET!-MODULUS OLD!-M
  2588. END;
  2589. SYMBOLIC PROCEDURE CONVERT!-NULL!-VECTORS!-TO!-FACTORS M!-INFO;
  2590. % Using the null space found, complete the job
  2591. % of finding modular factors by taking gcd's of the
  2592. % modular input polynomial and variants on the
  2593. % null space generators;
  2594. BEGIN
  2595. SCALAR NUMBER!-NEEDED,FACTORS,
  2596. WORK!-VECTOR1,DWORK1,WORK!-VECTOR2,DWORK2,WTIME;
  2597. KNOWN!-FACTORS:=NIL;
  2598. WTIME:=TIME();
  2599. FIND!-LINEAR!-FACTORS!-MOD!-P(CDAR M!-INFO,CAAR M!-INFO);
  2600. TRACE!-TIME DISPLAY!-TIME("Linear factors found in ",TIME()-WTIME);
  2601. DPOLY:=CAADR M!-INFO;
  2602. POLY!-VECTOR:=CDADR M!-INFO;
  2603. NULL!-SPACE!-BASIS:=CADDR M!-INFO;
  2604. IF DPOLY=0 THEN RETURN KNOWN!-FACTORS; % All factors were linear;
  2605. IF NULL NULL!-SPACE!-BASIS THEN
  2606. RETURN KNOWN!-FACTORS:=
  2607. VECTOR!-TO!-POLY(POLY!-VECTOR,DPOLY,M!-IMAGE!-VARIABLE) .
  2608. KNOWN!-FACTORS;
  2609. NUMBER!-NEEDED:=LENGTH NULL!-SPACE!-BASIS;
  2610. % count showing how many more factors I need to find;
  2611. WORK!-VECTOR1:=MKVECT DPOLY;
  2612. WORK!-VECTOR2:=MKVECT DPOLY;
  2613. FACTORS:=LIST (POLY!-VECTOR . DPOLY);
  2614. TRY!-NEXT!-NULL:
  2615. IF NULL!-SPACE!-BASIS=NIL THEN
  2616. ERRORF "RAN OUT OF NULL VECTORS TOO EARLY";
  2617. WTIME:=TIME();
  2618. FACTORS:=TRY!-ALL!-CONSTANTS(FACTORS,
  2619. CAAR NULL!-SPACE!-BASIS,CDAR NULL!-SPACE!-BASIS);
  2620. TRACE!-TIME DISPLAY!-TIME("All constants tried in ",TIME()-WTIME);
  2621. IF NUMBER!-NEEDED=0 THEN
  2622. RETURN KNOWN!-FACTORS:=APPEND!-NEW!-FACTORS(FACTORS,
  2623. KNOWN!-FACTORS);
  2624. NULL!-SPACE!-BASIS:=CDR NULL!-SPACE!-BASIS;
  2625. GO TO TRY!-NEXT!-NULL
  2626. END;
  2627. SYMBOLIC PROCEDURE TRY!-ALL!-CONSTANTS(LIST!-OF!-POLYS,V,DV);
  2628. % use gcd's of v, v+1, v+2, ... to try to split up the
  2629. % polynomials in the given list;
  2630. BEGIN
  2631. SCALAR A,B,AA,S,WTIME;
  2632. % aa is a list of factors that can not be improved using this v,
  2633. % b is a list that might be;
  2634. AA:=NIL; B:=LIST!-OF!-POLYS;
  2635. S:=0;
  2636. TRY!-NEXT!-CONSTANT:
  2637. PUTV(V,0,S); % Fix constant term of V to be S;
  2638. % WTIME:=TIME();
  2639. A:=SPLIT!-FURTHER(B,V,DV);
  2640. % TRACE!-TIME DISPLAY!-TIME("Polys split further in ",TIME()-WTIME);
  2641. B:=CDR A; A:=CAR A;
  2642. AA:=NCONC(A,AA);
  2643. % Keep aa up to date as a list of polynomials that this poly
  2644. % v can not help further with;
  2645. IF B=NIL THEN RETURN AA; % no more progress possible here;
  2646. IF NUMBER!-NEEDED=0 THEN RETURN NCONC(B,AA);
  2647. % no more progress needed;
  2648. S:=S#+1;
  2649. IF S#<CURRENT!-MODULUS THEN GO TO TRY!-NEXT!-CONSTANT;
  2650. % Here I have run out of choices for the constant
  2651. % coefficient in v without splitting everything;
  2652. RETURN NCONC(B,AA)
  2653. END;
  2654. SYMBOLIC PROCEDURE SPLIT!-FURTHER(LIST!-OF!-POLYS,V,DV);
  2655. % list-of-polys is a list of polynomials. try to split
  2656. % its members further by taking gcd's with the polynomial
  2657. % v. return (a . b) where the polys in a can not possibly
  2658. % be split using v+constant, but the polys in b might
  2659. % be;
  2660. IF NULL LIST!-OF!-POLYS THEN NIL . NIL
  2661. ELSE BEGIN
  2662. SCALAR A,B,GG,Q;
  2663. A:=SPLIT!-FURTHER(CDR LIST!-OF!-POLYS,V,DV);
  2664. B:=CDR A; A:=CAR A;
  2665. IF NUMBER!-NEEDED=0 THEN GO TO NO!-SPLIT;
  2666. % if all required factors have been found there is no need to
  2667. % search further;
  2668. DWORK1:=COPY!-VECTOR(V,DV,WORK!-VECTOR1);
  2669. DWORK2:=COPY!-VECTOR(CAAR LIST!-OF!-POLYS,CDAR LIST!-OF!-POLYS,
  2670. WORK!-VECTOR2);
  2671. DWORK1:=GCD!-IN!-VECTOR(WORK!-VECTOR1,DWORK1,
  2672. WORK!-VECTOR2,DWORK2);
  2673. IF DWORK1=0 OR DWORK1=CDAR LIST!-OF!-POLYS THEN GO TO NO!-SPLIT;
  2674. DWORK2:=COPY!-VECTOR(CAAR LIST!-OF!-POLYS,CDAR LIST!-OF!-POLYS,
  2675. WORK!-VECTOR2);
  2676. DWORK2:=QUOTFAIL!-IN!-VECTOR(WORK!-VECTOR2,DWORK2,
  2677. WORK!-VECTOR1,DWORK1);
  2678. % Here I have a splitting;
  2679. GG:=MKVECT DWORK1;
  2680. COPY!-VECTOR(WORK!-VECTOR1,DWORK1,GG);
  2681. A:=((GG . DWORK1) . A);
  2682. COPY!-VECTOR(WORK!-VECTOR2,DWORK2,Q:=MKVECT DWORK2);
  2683. B:=((Q . DWORK2) . B);
  2684. NUMBER!-NEEDED:=NUMBER!-NEEDED#-1;
  2685. RETURN (A . B);
  2686. NO!-SPLIT:
  2687. RETURN (A . ((CAR LIST!-OF!-POLYS) . B))
  2688. END;
  2689. SYMBOLIC PROCEDURE APPEND!-NEW!-FACTORS(A,B);
  2690. % Convert to REDUCE (rather than vector) form;
  2691. IF NULL A THEN B
  2692. ELSE
  2693. VECTOR!-TO!-POLY(CAAR A,CDAR A,M!-IMAGE!-VARIABLE) .
  2694. APPEND!-NEW!-FACTORS(CDR A,B);
  2695. CARCHECK SAFE!-FLAG; % Restore status quo;
  2696. ENDMODULE;
  2697. MODULE FACPRIM;
  2698. % *******************************************************************
  2699. %
  2700. % copyright (c) university of cambridge, england 1979
  2701. %
  2702. % *******************************************************************;
  2703. %**********************************************************************;
  2704. %
  2705. % multivariate polynomial factorization more or less as described
  2706. % by paul wang in: math. comp. vol.32 no.144 oct 1978 pp. 1215-1231
  2707. % 'an improved multivariate polynomial factoring algorithm'
  2708. %
  2709. % p. m. a. moore. 1979.
  2710. %
  2711. %
  2712. %**********************************************************************;
  2713. %----------------------------------------------------------------------;
  2714. % this code works by using a local database of fluid variables
  2715. % whose meaning is (hopefully) obvious.
  2716. % they are used as follows:
  2717. %
  2718. % global name: set in: comments:
  2719. %
  2720. % m!-factored!-leading! create!.images only set if non-numeric
  2721. % -coefft
  2722. % m!-factored!-images factorize!.images vector
  2723. % m!-input!-polynomial factorize!-primitive!
  2724. % -polynomial
  2725. % m!-best!-image!-pointer choose!.best!.image
  2726. % m!-image!-factors choose!.best!.image vector
  2727. % m!-true!-leading! choose!.best!.image vector
  2728. % -coeffts
  2729. % m!-prime choose!.best!.image
  2730. % irreducible factorize!.images predicate
  2731. % inverted create!.images predicate
  2732. % m!-inverted!-sign create!-images +1 or -1
  2733. % non!-monic determine!-leading! predicate
  2734. % -coeffts
  2735. % (also reconstruct!-over!
  2736. % -integers)
  2737. % m!-number!-of!-factors choose!.best!.image
  2738. % m!-image!-variable square!.free!.factorize
  2739. % or factorize!-form
  2740. % m!-image!-sets create!.images vector
  2741. % this last contains the images of m!-input!-polynomial and the
  2742. % numbers associated with the factors of lc m!-input!-polynomial (to be
  2743. % used later) the latter existing only when the lc m!-input!-polynomial
  2744. % is non-integral. ie.:
  2745. % m!-image!-sets=< ... , (( d . u ), a, d) , ... > ( a vector)
  2746. % where: a = an image set (=association list);
  2747. % d = cont(m!-input!-polynomial image wrt a);
  2748. % u = prim.part.(same) which is non-trivial square-free
  2749. % by choice of image set.;
  2750. % d = vector of numbers associated with factors in lc
  2751. % m!-input!-polynomial (these depend on a as well);
  2752. % the number of entries in m!-image!-sets is defined by the fluid
  2753. % variable, no.of.random.sets;
  2754. %
  2755. %
  2756. %
  2757. %----------------------------------------------------------------------;
  2758. %**********************************************************************;
  2759. % multivariate factorization part 1. entry point for this code:
  2760. % ** n.b.** the polynomial is assumed to be non-trivial and primitive;
  2761. SYMBOLIC PROCEDURE SQUARE!.FREE!.FACTORIZE U;
  2762. % u primitive (multivariate) poly but not yet square free.
  2763. % result is list of factors consed with their respective multiplicities:
  2764. % ((f1 . m1),(f2 . m2),...) where mi may = mj when i not = j ;
  2765. % u is non-trivial - ie. at least linear in some variable;
  2766. %***** nb. this does not use best square free method *****;
  2767. BEGIN SCALAR V,W,X,Y,I,NEWU,F!.LIST,SFP!-COUNT;
  2768. SFP!-COUNT:=0;
  2769. FACTOR!-TRACE
  2770. IF NOT U=POLYNOMIAL!-TO!-FACTOR THEN
  2771. << PRIN2!* "Primitive polynomial to factor: ";
  2772. FAC!-PRINTSF U >>;
  2773. IF NULL M!-IMAGE!-VARIABLE THEN
  2774. ERRORF LIST("M-IMAGE-VARIABLE not set: ",U);
  2775. V:=POLY!-GCD(U,
  2776. DERIVATIVE!-WRT!-MAIN!-VARIABLE(U,M!-IMAGE!-VARIABLE));
  2777. IF ONEP V THEN <<
  2778. FACTOR!-TRACE PRINTSTR "The polynomial is square-free.";
  2779. RETURN SQUARE!-FREE!-PRIM!-FACTOR(U,1) >>
  2780. ELSE FACTOR!-TRACE <<
  2781. PRINTSTR
  2782. "We now square-free decompose this to produce a series of ";
  2783. PRINTSTR
  2784. "(square-free primitive) factors which we treat in turn: ";
  2785. TERPRI(); TERPRI() >>;
  2786. W:=QUOTFAIL(U,V);
  2787. X:=POLY!-GCD(V,W);
  2788. NEWU:=QUOTFAIL(W,X);
  2789. IF NOT ONEP NEWU THEN
  2790. << F!.LIST:=APPEND(F!.LIST,
  2791. SQUARE!-FREE!-PRIM!-FACTOR(NEWU,1))
  2792. >>;
  2793. I:=2; % power of next factors;
  2794. % from now on we can avoid an extra gcd and any diffn;
  2795. WHILE NOT DOMAINP V DO
  2796. << V:=QUOTFAIL(V,X);
  2797. W:=QUOTFAIL(W,NEWU);
  2798. X:=POLY!-GCD(V,W);
  2799. NEWU:=QUOTFAIL(W,X);
  2800. IF NOT ONEP NEWU THEN
  2801. << F!.LIST:=APPEND(F!.LIST,
  2802. SQUARE!-FREE!-PRIM!-FACTOR(NEWU,I))
  2803. >>;
  2804. I:=IADD1 I
  2805. >>;
  2806. IF NOT V=1 THEN F!.LIST:=(V . 1) . F!.LIST;
  2807. RETURN F!.LIST
  2808. END;
  2809. SYMBOLIC PROCEDURE SQUARE!-FREE!-PRIM!-FACTOR(U,I);
  2810. % factorize the square-free primitive factor u whose multiplicity
  2811. % in the original poly is i. return the factors consed with this
  2812. % multiplicity;
  2813. BEGIN SCALAR W;
  2814. SFP!-COUNT:=IADD1 SFP!-COUNT;
  2815. FACTOR!-TRACE <<
  2816. IF NOT(U=POLYNOMIAL!-TO!-FACTOR) THEN <<
  2817. PRIN2!* "("; PRIN2!* SFP!-COUNT;
  2818. PRIN2!* ") Square-free primitive factor: "; FAC!-PRINTSF U;
  2819. PRIN2!* " with multiplicity "; PRIN2!* I;
  2820. TERPRI!*(NIL) >> >>;
  2821. W:=DISTRIBUTE!.MULTIPLICITY(FACTORIZE!-PRIMITIVE!-POLYNOMIAL U,I);
  2822. FACTOR!-TRACE
  2823. IF NOT U=POLYNOMIAL!-TO!-FACTOR THEN <<
  2824. PRIN2!* "Factors of ("; PRIN2!* SFP!-COUNT;
  2825. PRINTSTR ") are: "; FAC!-PRINTFACTORS(1 . W);
  2826. TERPRI(); TERPRI() >>;
  2827. RETURN W
  2828. END;
  2829. SYMBOLIC PROCEDURE DISTRIBUTE!.MULTIPLICITY(FACTORLIST,N);
  2830. % factorlist is a simple list of factors of a square free primitive
  2831. % multivariate poly and n is their multiplicity in a square free
  2832. % decomposition of another polynomial. result is a list of form:
  2833. % ((f1 . n),(f2 . n),...) where fi are the factors.;
  2834. FOR EACH W IN FACTORLIST COLLECT (W . N);
  2835. SYMBOLIC PROCEDURE FACTORIZE!-PRIMITIVE!-POLYNOMIAL U;
  2836. % u is primitive square free and at least linear in
  2837. % m!-image!-variable. m!-image!-variable is the variable preserved in
  2838. % the univariate images. this function determines a random set of
  2839. % integers and a prime to create a univariate modular image of u,
  2840. % factorize it and determine the leading coeffts of the factors in the
  2841. % full factorization of u. finally the modular image factors are grown
  2842. % up to the full multivariates ones using the hensel construction;
  2843. % result is simple list of irreducible factors;
  2844. IF DEGREE!-IN!-VARIABLE(U,M!-IMAGE!-VARIABLE) = 1 THEN LIST U
  2845. ELSE IF UNIVARIATEP U THEN
  2846. UNIVARIATE!-FACTORIZE U
  2847. ELSE BEGIN SCALAR
  2848. VALID!-IMAGE!-SETS,FACTORED!-LC,IMAGE!-FACTORS,PRIME!-BASE,
  2849. ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE,ZSET,ZEROVARSET,OTHERVARS,
  2850. MULTIVARIATE!-INPUT!-POLY,BEST!-SET!-POINTER,REDUCTION!-COUNT,
  2851. TRUE!-LEADING!-COEFFTS,NUMBER!-OF!-FACTORS,
  2852. INVERTED!-SIGN,IRREDUCIBLE,INVERTED,VARS!-TO!-KILL,
  2853. FORBIDDEN!-SETS,ZERO!-SET!-TRIED,NON!-MONIC,
  2854. NO!-OF!-BEST!-SETS,NO!-OF!-RANDOM!-SETS,BAD!-CASE,
  2855. TARGET!-FACTOR!-COUNT,MODULAR!-INFO,MULTIVARIATE!-FACTORS,
  2856. HENSEL!-GROWTH!-SIZE,ALPHALIST,BASE!-TIMER,W!-TIME,
  2857. PREVIOUS!-DEGREE!-MAP,IMAGE!-SET!-MODULUS,COEFFTS!-VECTORS,
  2858. BEST!-KNOWN!-FACTORS,RECONSTRUCTING!-GCD,FULL!-GCD;
  2859. BASE!-TIMER:=TIME();
  2860. TRACE!-TIME DISPLAY!-TIME(
  2861. " Entered multivariate primitive polynomial code after ",
  2862. BASE!-TIMER - BASE!-TIME);
  2863. %note that this code works by using a local database of
  2864. %fluid variables that are updated by the subroutines directly
  2865. %called here. this allows for the relativly complicated
  2866. %interaction between flow of data and control that occurs in
  2867. %the factorization algorithm;
  2868. FACTOR!-TRACE <<
  2869. PRINTSTR "From now on we shall refer to this polynomial as U.";
  2870. PRINTSTR
  2871. "We now create an image of U by picking suitable values ";
  2872. PRINTSTR "for all but one of the variables in U.";
  2873. PRIN2!* "The variable preserved in the image is ";
  2874. PRINVAR M!-IMAGE!-VARIABLE; TERPRI!*(NIL) >>;
  2875. INITIALIZE!-FLUIDS U;
  2876. % set up the fluids to start things off;
  2877. W!-TIME:=TIME();
  2878. TRYAGAIN:
  2879. GET!-SOME!-RANDOM!-SETS();
  2880. CHOOSE!-THE!-BEST!-SET();
  2881. TRACE!-TIME <<
  2882. DISPLAY!-TIME("Modular factoring and best set chosen in ",
  2883. TIME()-W!-TIME);
  2884. W!-TIME:=TIME() >>;
  2885. IF IRREDUCIBLE THEN
  2886. RETURN LIST U
  2887. ELSE IF BAD!-CASE THEN <<
  2888. IF !*OVERSHOOT THEN PRINTC "Bad image sets - loop";
  2889. BAD!-CASE:=NIL; GOTO TRYAGAIN >>;
  2890. RECONSTRUCT!-IMAGE!-FACTORS!-OVER!-INTEGERS();
  2891. TRACE!-TIME <<
  2892. DISPLAY!-TIME("Image factors reconstructed in ",TIME()-W!-TIME);
  2893. W!-TIME:=TIME() >>;
  2894. IF IRREDUCIBLE THEN
  2895. RETURN LIST U
  2896. ELSE IF BAD!-CASE THEN <<
  2897. IF !*OVERSHOOT THEN PRINTC "Bad image factors - loop";
  2898. BAD!-CASE:=NIL; GOTO TRYAGAIN >>;
  2899. DETERMINE!.LEADING!.COEFFTS();
  2900. TRACE!-TIME <<
  2901. DISPLAY!-TIME("Leading coefficients distributed in ",
  2902. TIME()-W!-TIME);
  2903. W!-TIME:=TIME() >>;
  2904. IF IRREDUCIBLE THEN
  2905. RETURN LIST U
  2906. ELSE IF BAD!-CASE THEN <<
  2907. IF !*OVERSHOOT THEN PRINTC "Bad split shown by LC distribution";
  2908. BAD!-CASE:=NIL; GOTO TRYAGAIN >>;
  2909. IF DETERMINE!-MORE!-COEFFTS()='DONE THEN <<
  2910. TRACE!-TIME <<
  2911. DISPLAY!-TIME("All the coefficients distributed in ",
  2912. TIME()-W!-TIME);
  2913. W!-TIME:=TIME() >>;
  2914. RETURN CHECK!-INVERTED MULTIVARIATE!-FACTORS >>;
  2915. TRACE!-TIME <<
  2916. DISPLAY!-TIME("More coefficients distributed in ",
  2917. TIME()-W!-TIME);
  2918. W!-TIME:=TIME() >>;
  2919. RECONSTRUCT!-MULTIVARIATE!-FACTORS(NIL);
  2920. IF BAD!-CASE AND NOT IRREDUCIBLE THEN <<
  2921. IF !*OVERSHOOT THEN PRINTC "Multivariate overshoot - restart";
  2922. BAD!-CASE:=NIL; GOTO TRYAGAIN >>;
  2923. TRACE!-TIME
  2924. DISPLAY!-TIME("Multivariate factors reconstructed in ",
  2925. TIME()-W!-TIME);
  2926. IF IRREDUCIBLE THEN
  2927. RETURN LIST U;
  2928. RETURN CHECK!-INVERTED MULTIVARIATE!-FACTORS
  2929. END;
  2930. SYMBOLIC PROCEDURE INITIALIZE!-FLUIDS U;
  2931. % Set up the fluids to be used in factoring primitive poly;
  2932. BEGIN SCALAR W,W1,WTIME;
  2933. IF !*FORCE!-ZERO!-SET THEN <<
  2934. NO!-OF!-RANDOM!-SETS:=1;
  2935. NO!-OF!-BEST!-SETS:=1 >>
  2936. ELSE <<
  2937. NO!-OF!-RANDOM!-SETS:=9;
  2938. % we generate this many and calculate their factor counts;
  2939. NO!-OF!-BEST!-SETS:=5;
  2940. % we find the modular factors of this many;
  2941. >>;
  2942. IMAGE!-SET!-MODULUS:=5;
  2943. VARS!-TO!-KILL:=VARIABLES!-TO!-KILL LC U;
  2944. MULTIVARIATE!-INPUT!-POLY:=U;
  2945. TARGET!-FACTOR!-COUNT:=DEGREE!-IN!-VARIABLE(U,M!-IMAGE!-VARIABLE);
  2946. IF NOT DOMAINP LC MULTIVARIATE!-INPUT!-POLY THEN
  2947. IF DOMAINP (W:=
  2948. TRAILING!.COEFFT(MULTIVARIATE!-INPUT!-POLY,
  2949. M!-IMAGE!-VARIABLE)) THEN
  2950. << INVERTED:=T;
  2951. % note that we are 'inverting' the poly m!-input!-polynomial;
  2952. W1:=INVERT!.POLY(MULTIVARIATE!-INPUT!-POLY,M!-IMAGE!-VARIABLE);
  2953. MULTIVARIATE!-INPUT!-POLY:=CDR W1;
  2954. INVERTED!-SIGN:=CAR W1;
  2955. % to ease the lc problem, m!-input!-polynomial <- poly
  2956. % produced by taking numerator of (m!-input!-polynomial
  2957. % with 1/m!-image!-variable substituted for
  2958. % m!-image!-variable);
  2959. % m!-inverted!-sign is -1 if we have inverted the sign of
  2960. % the resulting poly to keep it +ve, else +1;
  2961. FACTOR!-TRACE <<
  2962. PRIN2!* "The trailing coefficient of U wrt ";
  2963. PRINVAR M!-IMAGE!-VARIABLE; PRIN2!* "(="; PRIN2!* W;
  2964. PRINTSTR ") is purely numeric so we 'invert' U to give: ";
  2965. PRIN2!* " U <- "; FAC!-PRINTSF MULTIVARIATE!-INPUT!-POLY;
  2966. PRINTSTR "This simplifies any problems with the leading ";
  2967. PRINTSTR "coefficient of U." >>
  2968. >>
  2969. ELSE <<
  2970. TRACE!-TIME PRINTC "Factoring the leading coefficient:";
  2971. WTIME:=TIME();
  2972. FACTORED!-LC:=
  2973. FACTORIZE!-FORM!-RECURSION LC MULTIVARIATE!-INPUT!-POLY;
  2974. TRACE!-TIME DISPLAY!-TIME("Leading coefficient factored in ",
  2975. TIME()-WTIME);
  2976. % factorize the lc of m!-input!-polynomial completely;
  2977. FACTOR!-TRACE <<
  2978. PRINTSTR
  2979. "The leading coefficient of U is non-trivial so we must ";
  2980. PRINTSTR "factor it before we can decide how it is distributed";
  2981. PRINTSTR "over the leading coefficients of the factors of U.";
  2982. PRINTSTR "So the factors of this leading coefficient are:";
  2983. FAC!-PRINTFACTORS FACTORED!-LC >>
  2984. >>;
  2985. MAKE!-ZEROVARSET VARS!-TO!-KILL;
  2986. % Sets ZEROVARSET and OTHERVARS;
  2987. IF NULL ZEROVARSET THEN ZERO!-SET!-TRIED:=T
  2988. ELSE <<
  2989. ZSET:=MAKE!-ZEROSET!-LIST LENGTH ZEROVARSET;
  2990. SAVE!-ZSET:=ZSET >>
  2991. END;
  2992. SYMBOLIC PROCEDURE VARIABLES!-TO!-KILL LC!-U;
  2993. % picks out all the variables in u except var. also checks to see if
  2994. % any of these divide lc u: if they do they are dotted with t otherwise
  2995. % dotted with nil. result is list of these dotted pairs;
  2996. FOR EACH W IN CDR KORD!* COLLECT
  2997. IF (DOMAINP LC!-U) OR DIDNTGO QUOTF(LC!-U,!*K2F W) THEN
  2998. (W . NIL) ELSE (W . T);
  2999. %**********************************************************************;
  3000. % multivariate factorization part 2. creating image sets and picking
  3001. % the best one;
  3002. FLUID '(USABLE!-SET!-FOUND);
  3003. SYMBOLIC PROCEDURE GET!-SOME!-RANDOM!-SETS();
  3004. % here we create a number of random sets to make the input
  3005. % poly univariate by killing all but 1 of the variables. at
  3006. % the same time we pick a random prime to reduce this image
  3007. % poly mod p;
  3008. BEGIN SCALAR IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P,WTIME,
  3009. IMAGE!-CONTENT,IMAGE!-POLY,F!-NUMVEC,FORBIDDEN!-PRIMES,I,J,
  3010. USABLE!-SET!-FOUND;
  3011. VALID!-IMAGE!-SETS:=MKVECT NO!-OF!-RANDOM!-SETS;
  3012. I:=0;
  3013. WHILE I < NO!-OF!-RANDOM!-SETS DO <<
  3014. WTIME:=TIME();
  3015. GENERATE!-AN!-IMAGE!-SET!-WITH!-PRIME(
  3016. IF I<IDIFFERENCE(NO!-OF!-RANDOM!-SETS,3) THEN NIL ELSE T);
  3017. TRACE!-TIME
  3018. DISPLAY!-TIME(" Image set generated in ",TIME()-WTIME);
  3019. I:=IADD1 I;
  3020. PUTV(VALID!-IMAGE!-SETS,I,LIST(
  3021. IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P,IMAGE!-CONTENT,
  3022. IMAGE!-POLY,F!-NUMVEC));
  3023. FORBIDDEN!-SETS:=IMAGE!-SET . FORBIDDEN!-SETS;
  3024. FORBIDDEN!-PRIMES:=LIST CHOSEN!-PRIME;
  3025. J:=1;
  3026. WHILE (J<3) AND (I<NO!-OF!-RANDOM!-SETS) DO <<
  3027. WTIME:=TIME();
  3028. IMAGE!-MOD!-P:=FIND!-A!-VALID!-PRIME(IMAGE!-LC,IMAGE!-POLY,
  3029. NOT NUMBERP IMAGE!-CONTENT);
  3030. IF NOT(IMAGE!-MOD!-P='NOT!-SQUARE!-FREE) THEN <<
  3031. TRACE!-TIME
  3032. DISPLAY!-TIME(" Prime and image mod p found in ",
  3033. TIME()-WTIME);
  3034. I:=IADD1 I;
  3035. PUTV(VALID!-IMAGE!-SETS,I,LIST(
  3036. IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P,
  3037. IMAGE!-CONTENT,IMAGE!-POLY,F!-NUMVEC));
  3038. FORBIDDEN!-PRIMES:=CHOSEN!-PRIME . FORBIDDEN!-PRIMES >>;
  3039. J:=IADD1 J
  3040. >>
  3041. >>
  3042. END;
  3043. SYMBOLIC PROCEDURE CHOOSE!-THE!-BEST!-SET();
  3044. % given several random sets we now choose the best by factoring
  3045. % each image mod its chosen prime and taking one with the
  3046. % lowest factor count as the best for hensel growth;
  3047. BEGIN SCALAR SPLIT!-LIST,POLY!-MOD!-P,NULL!-SPACE!-BASIS,
  3048. KNOWN!-FACTORS,W,N,FNUM,REMAINING!-SPLIT!-LIST,WTIME;
  3049. MODULAR!-INFO:=MKVECT NO!-OF!-RANDOM!-SETS;
  3050. WTIME:=TIME();
  3051. FOR I:=1:NO!-OF!-RANDOM!-SETS DO <<
  3052. W:=GETV(VALID!-IMAGE!-SETS,I);
  3053. GET!-FACTOR!-COUNT!-MOD!-P(I,GET!-IMAGE!-MOD!-P W,
  3054. GET!-CHOSEN!-PRIME W,NOT NUMBERP GET!-IMAGE!-CONTENT W) >>;
  3055. SPLIT!-LIST:=SORT(SPLIT!-LIST,FUNCTION LESSPPAIR);
  3056. % this now contains a list of pairs (m . n) where
  3057. % m is the no: of factors in image no: n. the list
  3058. % is sorted with best split (smallest m) first;
  3059. TRACE!-TIME
  3060. DISPLAY!-TIME(" Factor counts found in ",TIME()-WTIME);
  3061. IF CAAR SPLIT!-LIST = 1 THEN <<
  3062. IRREDUCIBLE:=T; RETURN NIL >>;
  3063. W:=NIL;
  3064. WTIME:=TIME();
  3065. FOR I:=1:NO!-OF!-BEST!-SETS DO <<
  3066. N:=CDAR SPLIT!-LIST;
  3067. GET!-FACTORS!-MOD!-P(N,
  3068. GET!-CHOSEN!-PRIME GETV(VALID!-IMAGE!-SETS,N));
  3069. W:=(CAR SPLIT!-LIST) . W;
  3070. SPLIT!-LIST:=CDR SPLIT!-LIST >>;
  3071. % pick the best few of these and find out their
  3072. % factors mod p;
  3073. TRACE!-TIME
  3074. DISPLAY!-TIME(" Best factors mod p found in ",TIME()-WTIME);
  3075. REMAINING!-SPLIT!-LIST:=SPLIT!-LIST;
  3076. SPLIT!-LIST:=REVERSEWOC W;
  3077. % keep only those images that are fully factored mod p;
  3078. WTIME:=TIME();
  3079. CHECK!-DEGREE!-SETS(NO!-OF!-BEST!-SETS,T);
  3080. % the best image is pointed at by best!-set!-pointer;
  3081. TRACE!-TIME
  3082. DISPLAY!-TIME(" Degree sets analysed in ",TIME()-WTIME);
  3083. % now if these didn't help try the rest to see
  3084. % if we can avoid finding new image sets altogether: ;
  3085. IF BAD!-CASE THEN <<
  3086. BAD!-CASE:=NIL;
  3087. WTIME:=TIME();
  3088. WHILE REMAINING!-SPLIT!-LIST DO <<
  3089. N:=CDAR REMAINING!-SPLIT!-LIST;
  3090. GET!-FACTORS!-MOD!-P(N,
  3091. GET!-CHOSEN!-PRIME GETV(VALID!-IMAGE!-SETS,N));
  3092. W:=(CAR REMAINING!-SPLIT!-LIST) . W;
  3093. REMAINING!-SPLIT!-LIST:=CDR REMAINING!-SPLIT!-LIST >>;
  3094. TRACE!-TIME
  3095. DISPLAY!-TIME(" More sets factored mod p in ",TIME()-WTIME);
  3096. SPLIT!-LIST:=REVERSEWOC W;
  3097. WTIME:=TIME();
  3098. CHECK!-DEGREE!-SETS(NO!-OF!-RANDOM!-SETS - NO!-OF!-BEST!-SETS,T);
  3099. % best!-set!-pointer hopefully points at the best image ;
  3100. TRACE!-TIME
  3101. DISPLAY!-TIME(" More degree sets analysed in ",TIME()-WTIME)
  3102. >>;
  3103. ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE:=T;
  3104. FACTOR!-TRACE <<
  3105. W:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER);
  3106. PRIN2!* "The chosen image set is: ";
  3107. FOR EACH X IN GET!-IMAGE!-SET W DO <<
  3108. PRINVAR CAR X; PRIN2!* "="; PRIN2!* CDR X; PRIN2!* "; " >>;
  3109. TERPRI!*(NIL);
  3110. PRIN2!* "and chosen prime is "; PRINTSTR GET!-CHOSEN!-PRIME W;
  3111. PRINTSTR "Image polynomial (made primitive) = ";
  3112. FAC!-PRINTSF GET!-IMAGE!-POLY W;
  3113. IF NOT(GET!-IMAGE!-CONTENT W=1) THEN <<
  3114. PRIN2!* " with (extracted) content of ";
  3115. FAC!-PRINTSF GET!-IMAGE!-CONTENT W >>;
  3116. PRIN2!* "The image polynomial mod "; PRIN2!* GET!-CHOSEN!-PRIME W;
  3117. PRINTSTR ", made monic, is:";
  3118. FAC!-PRINTSF GET!-IMAGE!-MOD!-P W;
  3119. PRINTSTR "and factors of the primitive image mod this prime are:";
  3120. FOR EACH X IN GETV(MODULAR!-INFO,BEST!-SET!-POINTER)
  3121. DO FAC!-PRINTSF X;
  3122. IF (FNUM:=GET!-F!-NUMVEC W) AND NOT !*OVERVIEW THEN <<
  3123. PRINTSTR "The numeric images of each (square-free) factor of";
  3124. PRINTSTR "the leading coefficient of the polynomial are as";
  3125. PRIN2!* "follows (in order):";
  3126. PRIN2!* " ";
  3127. FOR I:=1:LENGTH CDR FACTORED!-LC DO <<
  3128. PRIN2!* GETV(FNUM,I); PRIN2!* "; " >>;
  3129. TERPRI!*(NIL) >>
  3130. >>
  3131. END;
  3132. %**********************************************************************;
  3133. % multivariate factorization part 3. reconstruction of the
  3134. % chosen image over the integers;
  3135. SYMBOLIC PROCEDURE RECONSTRUCT!-IMAGE!-FACTORS!-OVER!-INTEGERS();
  3136. % the hensel construction from modular case to univariate
  3137. % over the integers;
  3138. BEGIN SCALAR BEST!-MODULUS,BEST!-FACTOR!-COUNT,INPUT!-POLYNOMIAL,
  3139. INPUT!-LEADING!-COEFFICIENT,BEST!-KNOWN!-FACTORS,S,W,I,
  3140. X!-IS!-FACTOR,X!-FACTOR;
  3141. S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER);
  3142. BEST!-KNOWN!-FACTORS:=GETV(MODULAR!-INFO,BEST!-SET!-POINTER);
  3143. BEST!-MODULUS:=GET!-CHOSEN!-PRIME S;
  3144. BEST!-FACTOR!-COUNT:=LENGTH BEST!-KNOWN!-FACTORS;
  3145. INPUT!-POLYNOMIAL:=GET!-IMAGE!-POLY S;
  3146. IF LDEG INPUT!-POLYNOMIAL=1 THEN
  3147. IF NOT(X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT S) THEN
  3148. ERRORF LIST("Trying to factor a linear image poly: ",
  3149. INPUT!-POLYNOMIAL)
  3150. ELSE BEGIN SCALAR BRECIP,WW,OM,X!-MOD!-P;
  3151. NUMBER!-OF!-FACTORS:=2;
  3152. PRIME!-BASE:=BEST!-MODULUS;
  3153. X!-FACTOR:=!*K2F M!-IMAGE!-VARIABLE;
  3154. PUTV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER,
  3155. PUT!-IMAGE!-POLY!-AND!-CONTENT(S,LC GET!-IMAGE!-CONTENT S,
  3156. MULTF(X!-FACTOR,GET!-IMAGE!-POLY S)));
  3157. OM:=SET!-MODULUS BEST!-MODULUS;
  3158. BRECIP:=MODULAR!-RECIPROCAL
  3159. RED (WW:=REDUCE!-MOD!-P INPUT!-POLYNOMIAL);
  3160. X!-MOD!-P:=!*F2MOD X!-FACTOR;
  3161. ALPHALIST:=LIST(
  3162. (X!-MOD!-P . BRECIP),
  3163. (WW . MODULAR!-MINUS MODULAR!-TIMES(BRECIP,LC WW)));
  3164. DO!-QUADRATIC!-GROWTH(LIST(X!-FACTOR,INPUT!-POLYNOMIAL),
  3165. LIST(X!-MOD!-P,WW),BEST!-MODULUS);
  3166. W:=LIST INPUT!-POLYNOMIAL; % All factors apart from X-FACTOR;
  3167. SET!-MODULUS OM
  3168. END
  3169. ELSE <<
  3170. INPUT!-LEADING!-COEFFICIENT:=LC INPUT!-POLYNOMIAL;
  3171. FACTOR!-TRACE <<
  3172. PRINTSTR
  3173. "Next we use the Hensel Construction to grow these modular";
  3174. PRINTSTR "factors into factors over the integers." >>;
  3175. W:=RECONSTRUCT!.OVER!.INTEGERS();
  3176. IF IRREDUCIBLE THEN RETURN T;
  3177. IF (X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT S) THEN <<
  3178. NUMBER!-OF!-FACTORS:=LENGTH W + 1;
  3179. X!-FACTOR:=!*K2F M!-IMAGE!-VARIABLE;
  3180. PUTV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER,
  3181. PUT!-IMAGE!-POLY!-AND!-CONTENT(S,LC GET!-IMAGE!-CONTENT S,
  3182. MULTF(X!-FACTOR,GET!-IMAGE!-POLY S)));
  3183. FIX!-ALPHAS() >>
  3184. ELSE NUMBER!-OF!-FACTORS:=LENGTH W;
  3185. IF NUMBER!-OF!-FACTORS=1 THEN RETURN IRREDUCIBLE:=T >>;
  3186. IF NUMBER!-OF!-FACTORS>TARGET!-FACTOR!-COUNT THEN
  3187. RETURN BAD!-CASE:=LIST GET!-IMAGE!-SET S;
  3188. IMAGE!-FACTORS:=MKVECT NUMBER!-OF!-FACTORS;
  3189. I:=1;
  3190. FACTOR!-TRACE
  3191. PRINTSTR "The full factors of the image polynomial are:";
  3192. FOR EACH IM!-FACTOR IN W DO <<
  3193. PUTV(IMAGE!-FACTORS,I,IM!-FACTOR);
  3194. FACTOR!-TRACE FAC!-PRINTSF IM!-FACTOR;
  3195. I:=IADD1 I >>;
  3196. IF X!-IS!-FACTOR THEN <<
  3197. PUTV(IMAGE!-FACTORS,I,X!-FACTOR);
  3198. FACTOR!-TRACE <<
  3199. FAC!-PRINTSF X!-FACTOR;
  3200. FAC!-PRINTSF GET!-IMAGE!-CONTENT
  3201. GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER) >> >>
  3202. END;
  3203. SYMBOLIC PROCEDURE DO!-QUADRATIC!-GROWTH(FLIST,MODFLIST,P);
  3204. BEGIN SCALAR FHATVEC,ALPHAVEC,FACTORVEC,MODFVEC,FACVEC,
  3205. CURRENT!-FACTOR!-PRODUCT,OM,I,DELTAM,M;
  3206. FHATVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3207. ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3208. FACTORVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3209. MODFVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3210. FACVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3211. CURRENT!-FACTOR!-PRODUCT:=1;
  3212. I:=0;
  3213. FOR EACH FF IN FLIST DO <<
  3214. PUTV(FACTORVEC,I:=IADD1 I,FF);
  3215. CURRENT!-FACTOR!-PRODUCT:=MULTF(FF,CURRENT!-FACTOR!-PRODUCT) >>;
  3216. I:=0;
  3217. FOR EACH MODFF IN MODFLIST DO <<
  3218. PUTV(MODFVEC,I:=IADD1 I,MODFF);
  3219. PUTV(ALPHAVEC,I,CDR GET!-ALPHA MODFF) >>;
  3220. DELTAM:=P;
  3221. M:=DELTAM*DELTAM;
  3222. WHILE M<LARGEST!-SMALL!-MODULUS DO <<
  3223. QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS);
  3224. M:=M*DELTAM >>;
  3225. HENSEL!-GROWTH!-SIZE:=DELTAM;
  3226. ALPHALIST:=NIL;
  3227. FOR J:=1:NUMBER!-OF!-FACTORS DO
  3228. ALPHALIST:=(REDUCE!-MOD!-P GETV(FACTORVEC,J) . GETV(ALPHAVEC,J))
  3229. . ALPHALIST
  3230. END;
  3231. SYMBOLIC PROCEDURE FIX!-ALPHAS();
  3232. % we extracted a factor x (where x is the image variable)
  3233. % before any alphas were calculated, we now need to put
  3234. % back this factor and its coresponding alpha which incidently
  3235. % will change the other alphas;
  3236. BEGIN SCALAR OM,F1,X!-FACTOR,A,ARECIP,B;
  3237. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  3238. F1:=REDUCE!-MOD!-P INPUT!-POLYNOMIAL;
  3239. X!-FACTOR:=!*F2MOD !*K2F M!-IMAGE!-VARIABLE;
  3240. ARECIP:=MODULAR!-RECIPROCAL
  3241. (A:=EVALUATE!-MOD!-P(F1,M!-IMAGE!-VARIABLE,0));
  3242. B:=TIMES!-MOD!-P(MODULAR!-MINUS ARECIP,
  3243. QUOTFAIL!-MOD!-P(DIFFERENCE!-MOD!-P(F1,A),X!-FACTOR));
  3244. ALPHALIST:=(X!-FACTOR . ARECIP) .
  3245. (FOR EACH AA IN ALPHALIST COLLECT
  3246. ((CAR AA) . REMAINDER!-MOD!-P(TIMES!-MOD!-P(B,CDR AA),CAR AA)));
  3247. SET!-MODULUS OM
  3248. END;
  3249. %**********************************************************************;
  3250. % multivariate factorization part 4. determining the leading
  3251. % coefficients;
  3252. SYMBOLIC PROCEDURE DETERMINE!.LEADING!.COEFFTS();
  3253. % this function determines the leading coeffts to all but a constant
  3254. % factor which is spread over all of the factors before reconstruction;
  3255. BEGIN SCALAR DELTA,C,S;
  3256. S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER);
  3257. DELTA:=GET!-IMAGE!-CONTENT S;
  3258. % cont(the m!-input!-polynomial image);
  3259. IF NOT DOMAINP LC MULTIVARIATE!-INPUT!-POLY THEN
  3260. << TRUE!-LEADING!-COEFFTS:=
  3261. DISTRIBUTE!.LC(NUMBER!-OF!-FACTORS,IMAGE!-FACTORS,S,
  3262. FACTORED!-LC);
  3263. IF BAD!-CASE THEN <<
  3264. BAD!-CASE:=LIST GET!-IMAGE!-SET S;
  3265. TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1;
  3266. IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T;
  3267. RETURN BAD!-CASE >>;
  3268. DELTA:=CAR TRUE!-LEADING!-COEFFTS;
  3269. TRUE!-LEADING!-COEFFTS:=CDR TRUE!-LEADING!-COEFFTS;
  3270. % if the lc problem exists then use wang's algorithm to
  3271. % distribute it over the factors. ;
  3272. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  3273. PRINTSTR "We now determine the leading coefficients of the ";
  3274. PRINTSTR "factors of U by using the factors of the leading";
  3275. PRINTSTR "coefficient of U and their (square-free) images";
  3276. PRINTSTR "referred to earlier:";
  3277. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  3278. PRINSF GETV(IMAGE!-FACTORS,I);
  3279. PRIN2!* " with l.c.: ";
  3280. FAC!-PRINTSF GETV(TRUE!-LEADING!-COEFFTS,I)
  3281. >> >>;
  3282. IF NOT ONEP DELTA THEN FACTOR!-TRACE <<
  3283. IF !*OVERVIEW THEN
  3284. << PRINTSTR
  3285. "In determining the leading coefficients of the factors";
  3286. PRIN2!* "of U, " >>;
  3287. PRIN2!* "We have an integer factor, ";
  3288. PRIN2!* DELTA;
  3289. PRINTSTR ", left over that we ";
  3290. PRINTSTR "cannot yet distribute correctly." >>
  3291. >>
  3292. ELSE <<
  3293. TRUE!-LEADING!-COEFFTS:=MKVECT NUMBER!-OF!-FACTORS;
  3294. FOR I:=1:NUMBER!-OF!-FACTORS DO
  3295. PUTV(TRUE!-LEADING!-COEFFTS,I,LC GETV(IMAGE!-FACTORS,I));
  3296. IF NOT ONEP DELTA THEN
  3297. FACTOR!-TRACE <<
  3298. PRIN2!* "U has a leading coefficient = ";
  3299. PRIN2!* DELTA;
  3300. PRINTSTR " which we cannot ";
  3301. PRINTSTR "yet distribute correctly over the image factors." >>
  3302. >>;
  3303. IF NOT ONEP DELTA THEN
  3304. << FOR I:=1:NUMBER!-OF!-FACTORS DO
  3305. << PUTV(IMAGE!-FACTORS,I,MULTF(DELTA,GETV(IMAGE!-FACTORS,I)));
  3306. PUTV(TRUE!-LEADING!-COEFFTS,I,
  3307. MULTF(DELTA,GETV(TRUE!-LEADING!-COEFFTS,I)))
  3308. >>;
  3309. DIVIDE!-ALL!-ALPHAS DELTA;
  3310. C:=EXPT(DELTA,ISUB1 NUMBER!-OF!-FACTORS);
  3311. MULTIVARIATE!-INPUT!-POLY:=MULTF(C,MULTIVARIATE!-INPUT!-POLY);
  3312. NON!-MONIC:=T;
  3313. FACTOR!-TRACE <<
  3314. PRINTSTR "(a) We multiply each of the image factors by the ";
  3315. PRINTSTR "absolute value of this constant and multiply";
  3316. PRIN2!* "U by ";
  3317. IF NOT(NUMBER!-OF!-FACTORS=2) THEN
  3318. << PRIN2!* DELTA; PRIN2!* "**";
  3319. PRIN2!* ISUB1 NUMBER!-OF!-FACTORS >>
  3320. ELSE PRIN2!* DELTA;
  3321. PRINTSTR " giving new image factors";
  3322. PRINTSTR "as follows: ";
  3323. FOR I:=1:NUMBER!-OF!-FACTORS DO
  3324. FAC!-PRINTSF GETV(IMAGE!-FACTORS,I)
  3325. >>
  3326. >>;
  3327. % if necessary, fiddle the remaining integer part of the
  3328. % lc of m!-input!-polynomial;
  3329. END;
  3330. %**********************************************************************;
  3331. % multivariate factorization part 5. reconstruction;
  3332. SYMBOLIC PROCEDURE RECONSTRUCT!-MULTIVARIATE!-FACTORS VSET!-MOD!-P;
  3333. % Hensel construction for multivariate case
  3334. % Full univariate split has already been prepared (if factoring);
  3335. % but we only need the modular factors and the true leading coeffts;
  3336. (LAMBDA FACTOR!-LEVEL; BEGIN
  3337. SCALAR S,OM,U0,ALPHAVEC,WTIME,PREDICTIONS,
  3338. BEST!-FACTORS!-MOD!-P,FHATVEC,W1,FVEC!-MOD!-P,D,DEGREE!-BOUNDS,
  3339. LC!-VEC;
  3340. ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS;
  3341. BEST!-FACTORS!-MOD!-P:=MKVECT NUMBER!-OF!-FACTORS;
  3342. LC!-VEC := MKVECT NUMBER!-OF!-FACTORS;
  3343. % This will preserve the LCs of the factors while we are working
  3344. % mod p since they may contain numbers that are bigger than the
  3345. % modulus.;
  3346. IF NOT(
  3347. (D:=MAX!-DEGREE(MULTIVARIATE!-INPUT!-POLY,0)) < PRIME!-BASE) THEN
  3348. FVEC!-MOD!-P:=CHOOSE!-LARGER!-PRIME D;
  3349. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  3350. IF NULL FVEC!-MOD!-P THEN <<
  3351. FVEC!-MOD!-P:=MKVECT NUMBER!-OF!-FACTORS;
  3352. FOR I:=1:NUMBER!-OF!-FACTORS DO
  3353. PUTV(FVEC!-MOD!-P,I,REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I)) >>;
  3354. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  3355. PUTV(ALPHAVEC,I,CDR GET!-ALPHA GETV(FVEC!-MOD!-P,I));
  3356. PUTV(BEST!-FACTORS!-MOD!-P,I,
  3357. REDUCE!-MOD!-P GETV(BEST!-KNOWN!-FACTORS,I));
  3358. PUTV(LC!-VEC,I,LC GETV(BEST!-KNOWN!-FACTORS,I)) >>;
  3359. % Set up the Alphas, input factors mod p and remember to save
  3360. % the LCs for use after finding the multivariate factors mod p;
  3361. IF NOT RECONSTRUCTING!-GCD THEN <<
  3362. S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER);
  3363. VSET!-MOD!-P:=FOR EACH V IN GET!-IMAGE!-SET S COLLECT
  3364. (CAR V . MODULAR!-NUMBER CDR V) >>;
  3365. % PRINC "KORD* =";% PRINT KORD!*;
  3366. % PRINC "ORDER OF VARIABLE SUBSTITUTION=";% PRINT VSET!-MOD!-P;
  3367. U0:=REDUCE!-MOD!-P MULTIVARIATE!-INPUT!-POLY;
  3368. SET!-DEGREE!-BOUNDS VSET!-MOD!-P;
  3369. WTIME:=TIME();
  3370. FACTOR!-TRACE <<
  3371. PRINTSTR
  3372. "We use the Hensel Construction to grow univariate modular";
  3373. PRINTSTR
  3374. "factors into multivariate modular factors, which will in";
  3375. PRINTSTR "turn be used in the later Hensel construction. The";
  3376. PRINTSTR "starting modular factors are:";
  3377. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,")=",BEST!-FACTORS!-MOD!-P);
  3378. PRIN2!* "The modulus is "; PRINTSTR CURRENT!-MODULUS >>;
  3379. FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(U0,
  3380. BEST!-FACTORS!-MOD!-P,
  3381. VSET!-MOD!-P);
  3382. IF BAD!-CASE THEN <<
  3383. TRACE!-TIME <<
  3384. DISPLAY!-TIME(" Multivariate modular factors failed in ",
  3385. TIME()-WTIME);
  3386. WTIME:=TIME() >>;
  3387. TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1;
  3388. IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T;
  3389. SET!-MODULUS OM;
  3390. RETURN BAD!-CASE >>;
  3391. TRACE!-TIME <<
  3392. DISPLAY!-TIME(" Multivariate modular factors found in ",
  3393. TIME()-WTIME);
  3394. WTIME:=TIME() >>;
  3395. FHATVEC:=MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(BEST!-FACTORS!-MOD!-P,
  3396. NUMBER!-OF!-FACTORS);
  3397. FOR I:=1:NUMBER!-OF!-FACTORS DO
  3398. PUTV(FVEC!-MOD!-P,I,GETV(BEST!-FACTORS!-MOD!-P,I));
  3399. MAKE!-VEC!-MODULAR!-SYMMETRIC(BEST!-FACTORS!-MOD!-P,
  3400. NUMBER!-OF!-FACTORS);
  3401. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  3402. % W1:=GETV(COEFFT!-VECTORS,I);
  3403. % PUTV(BEST!-KNOWN!-FACTORS,I,
  3404. % MERGE!-TERMS(GETV(BEST!-FACTORS!-MOD!-P,I),W1));
  3405. PUTV(BEST!-KNOWN!-FACTORS,I,
  3406. FORCE!-LC(GETV(BEST!-FACTORS!-MOD!-P,I),GETV(LC!-VEC,I)));
  3407. % Now we put back the LCs before growing the multivariate
  3408. % factors to be correct over the integers giving the final
  3409. % result;
  3410. >>;
  3411. WTIME:=TIME();
  3412. W1:=HENSEL!-MOD!-P(
  3413. MULTIVARIATE!-INPUT!-POLY,
  3414. FVEC!-MOD!-P,
  3415. BEST!-KNOWN!-FACTORS,
  3416. GET!.COEFFT!.BOUND(MULTIVARIATE!-INPUT!-POLY,
  3417. TOTAL!-DEGREE!-IN!-POWERS(MULTIVARIATE!-INPUT!-POLY,NIL)),
  3418. VSET!-MOD!-P,
  3419. HENSEL!-GROWTH!-SIZE);
  3420. IF CAR W1='OVERSHOT THEN <<
  3421. TRACE!-TIME <<
  3422. DISPLAY!-TIME(" Full factors failed in ",TIME()-WTIME);
  3423. WTIME:=TIME() >>;
  3424. TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1;
  3425. IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T;
  3426. SET!-MODULUS OM;
  3427. RETURN BAD!-CASE:=T >>;
  3428. IF NOT(CAR W1='OK) THEN ERRORF W1;
  3429. TRACE!-TIME <<
  3430. DISPLAY!-TIME(" Full factors found in ",TIME()-WTIME);
  3431. WTIME:=TIME() >>;
  3432. IF RECONSTRUCTING!-GCD THEN <<
  3433. FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS(
  3434. LIST GETV(CDR W1,1),M!-IMAGE!-VARIABLE,NIL)
  3435. ELSE GETV(CDR W1,1);
  3436. SET!-MODULUS OM;
  3437. RETURN FULL!-GCD >>;
  3438. FOR I:=1:GETV(CDR W1,0) DO
  3439. MULTIVARIATE!-FACTORS:=GETV(CDR W1,I) . MULTIVARIATE!-FACTORS;
  3440. IF NON!-MONIC THEN MULTIVARIATE!-FACTORS:=
  3441. PRIMITIVE!.PARTS(MULTIVARIATE!-FACTORS,M!-IMAGE!-VARIABLE,NIL);
  3442. FACTOR!-TRACE <<
  3443. PRINTSTR "The full multivariate factors are:";
  3444. FOR EACH X IN MULTIVARIATE!-FACTORS DO FAC!-PRINTSF X >>;
  3445. SET!-MODULUS OM;
  3446. END) (FACTOR!-LEVEL*100);
  3447. SYMBOLIC PROCEDURE CHECK!-INVERTED MULTI!-FACLIST;
  3448. BEGIN SCALAR INV!.SIGN,L;
  3449. IF INVERTED THEN <<
  3450. INV!.SIGN:=1;
  3451. MULTI!-FACLIST:=
  3452. FOR EACH X IN MULTI!-FACLIST COLLECT <<
  3453. L:=INVERT!.POLY(X,M!-IMAGE!-VARIABLE);
  3454. INV!.SIGN:=(CAR L) * INV!.SIGN;
  3455. CDR L >>;
  3456. IF NOT(INV!.SIGN=INVERTED!-SIGN) THEN
  3457. ERRORF LIST("INVERSION HAS LOST A SIGN",INV!.SIGN) >>;
  3458. RETURN MULTIVARIATE!-FACTORS:=MULTI!-FACLIST END;
  3459. ENDMODULE;
  3460. MODULE FACTOR;
  3461. % *******************************************************************
  3462. %
  3463. % copyright (c) university of cambridge, england 1979
  3464. %
  3465. % *******************************************************************;
  3466. % factorization of polynomials
  3467. %
  3468. % p. m. a. moore 1979.
  3469. %
  3470. %
  3471. %**********************************************************************;
  3472. SYMBOLIC PROCEDURE MULTIPLE!-RESULT(Z,W);
  3473. % z is a list of items (n . prefix-form), and the largest value
  3474. % of n must come first in this list. w is supposed to be an array
  3475. % name. the items in the list z are put into the array w;
  3476. BEGIN
  3477. SCALAR X,Y,N;
  3478. N:=(LENGTH Z)-1;
  3479. IF NOT IDP W THEN <<
  3480. LPRIM "ANSWERS WILL BE IN 'ANS'";
  3481. W:='ANS >>;
  3482. IF ATOM W AND (Y := DIMENSION W) AND NULL CDR Y THEN <<
  3483. % one dimensional array found;
  3484. Y := CAR Y-1;
  3485. IF CAAR Z>Y THEN REDERR "ARRAY TOO SMALL";
  3486. WHILE NOT Y<0 DO <<
  3487. IF NULL Z OR Y NEQ CAAR Z THEN SETELV(LIST(W,Y),0)
  3488. ELSE << SETELV(LIST(W,Y),CDAR Z); Z := CDR Z >>;
  3489. Y := Y-1 >>;
  3490. RETURN !*N2F N ./ 1 >>;
  3491. % here w was not the name of a 1-dimensional array, so i
  3492. % will spread the results out into various discrete variables;
  3493. Y := EXPLODE W;
  3494. W := NIL;
  3495. FOR EACH ZZ IN Z DO <<
  3496. W := INTERN COMPRESS APPEND(Y,EXPLODE CAR ZZ) . W;
  3497. SETK1(CAR W,CDR ZZ,T) >>;
  3498. IF LENGTH W=1 THEN LPRIM ACONC(W,"IS NOW NON-ZERO")
  3499. ELSE LPRIM ACONC(W,"ARE NOW NON-ZERO");
  3500. RETURN !*N2F N ./ 1
  3501. END;
  3502. %**********************************************************************;
  3503. SYMBOLIC PROCEDURE FACTORF U;
  3504. % This is the entry to the factorizer that is to be used
  3505. % by programmers working at the symbolic level. U is to
  3506. % be a standard form. FACTORF hands back a list giving the factors
  3507. % of U. The format of said list is described below in the
  3508. % comments with FACTORIZE!-FORM.
  3509. % Entry to the factorizer at any level other than this is at
  3510. % the programmers own risk!! ;
  3511. FACTORF1(U,NIL);
  3512. SYMBOLIC PROCEDURE FACTORF1(U,!*FORCE!-PRIME);
  3513. % This entry to the factorizer allows one to force
  3514. % the code to use some particular prime for its
  3515. % modular factorization. It is not for casual
  3516. % use;
  3517. BEGIN
  3518. SCALAR FACTOR!-LEVEL,BASE!-TIME,LAST!-DISPLAYED!-TIME,
  3519. GC!-BASE!-TIME,LAST!-DISPLAYED!-GC!-TIME,GCDSAVE,
  3520. CURRENT!-MODULUS,MODULUS!/2,W;
  3521. GCDSAVE := !*GCD;
  3522. !*GCD := T; % This code will not work otherwise! ;
  3523. SET!-TIME();
  3524. FACTOR!-LEVEL := 0;
  3525. W := FACTORIZE!-FORM U;
  3526. !*GCD := GCDSAVE;
  3527. RETURN W
  3528. END;
  3529. %**********************************************************************;
  3530. SYMBOLIC PROCEDURE FACTORIZE!-FORM P;
  3531. % input:
  3532. % p is a reduce standard form that is to be factorized
  3533. % over the integers
  3534. % result: (nc . l)
  3535. % where nc is numeric (may be just 1)
  3536. % and l is list of the form:
  3537. % ((p1 . x1) (p2 . x2) .. (pn . xn))
  3538. % where p<i> are standard forms and x<i> are integers,
  3539. % and p= product<i> p<i>**x<i>;
  3540. %
  3541. % method:
  3542. % (a) reorder polynomial to make the variable of lowest maximum
  3543. % degree the main one and the rest ordered similarly;
  3544. % (b) use contents and primitive parts to split p up as far as possible
  3545. % (c) use square-free decomposition to continue the process
  3546. % (c.1) detect & perform special processing on cyclotomic polynomials
  3547. % (d) use modular-based method to find factors over integers;
  3548. BEGIN SCALAR NEW!-KORDER,OLD!-KORDER;
  3549. NEW!-KORDER:=KERNORD(P,POLYZERO);
  3550. IF !*KERNREVERSE THEN NEW!-KORDER:=REVERSE NEW!-KORDER;
  3551. OLD!-KORDER:=SETKORDER NEW!-KORDER;
  3552. P:=REORDER P; % Make var of lowest degree the main one;
  3553. P:=FACTORIZE!-FORM1(P,NEW!-KORDER);
  3554. SETKORDER OLD!-KORDER;
  3555. P := (CAR P . FOR EACH W IN CDR P COLLECT
  3556. (REORDER CAR W . CDR W));
  3557. IF MINUSP CAR P AND NOT CDR P=NIL THEN
  3558. P := (- CAR P) . (NEGF CAADR P . CDADR P) . CDDR P;
  3559. RETURN P
  3560. END;
  3561. SYMBOLIC PROCEDURE FACTORIZE!-FORM1(P,GIVEN!-KORDER);
  3562. % input:
  3563. % p is a reduce standard form that is to be factorized
  3564. % over the integers
  3565. % given-korder is a list of kernels in the order of importance
  3566. % (ie when finding leading terms etc. we use this list)
  3567. % See FACTORIZE-FORM above;
  3568. IF DOMAINP P THEN (P . NIL)
  3569. ELSE BEGIN SCALAR M!-IMAGE!-VARIABLE,VAR!-LIST,
  3570. POLYNOMIAL!-TO!-FACTOR,N;
  3571. IF !*ALL!-CONTENTS THEN VAR!-LIST:=GIVEN!-KORDER
  3572. ELSE <<
  3573. M!-IMAGE!-VARIABLE:=CAR GIVEN!-KORDER;
  3574. VAR!-LIST:=LIST M!-IMAGE!-VARIABLE >>;
  3575. RETURN (LAMBDA FACTOR!-LEVEL;
  3576. << FACTOR!-TRACE <<
  3577. PRIN2!* "FACTOR : "; FAC!-PRINTSF P;
  3578. PRIN2!* "Chosen main variable is ";
  3579. PRINTVAR M!-IMAGE!-VARIABLE >>;
  3580. POLYNOMIAL!-TO!-FACTOR:=P;
  3581. N:=NUMERIC!-CONTENT P;
  3582. P:=QUOTF(P,N);
  3583. IF POLY!-MINUSP P THEN <<
  3584. P:=NEGF P;
  3585. N:=-N >>;
  3586. FACTOR!-TRACE <<
  3587. PRIN2!* "Numeric content = ";
  3588. FAC!-PRINTSF N >>;
  3589. P:=FACTORIZE!-BY!-CONTENTS(P,VAR!-LIST);
  3590. P:=N . SORT!-FACTORS P;
  3591. FACTOR!-TRACE <<
  3592. TERPRI(); TERPRI();
  3593. PRINTSTR "Final result is:"; FAC!-PRINTFACTORS P >>;
  3594. P >>)
  3595. (FACTOR!-LEVEL+1)
  3596. END;
  3597. SYMBOLIC PROCEDURE FACTORIZE!-FORM!-RECURSION P;
  3598. % this is essentially the same as FACTORIZE!-FORM except that
  3599. % we must be careful of stray minus signs due to a possible
  3600. % reordering in the recursive factoring;
  3601. BEGIN SCALAR S,N,X,RES,NEW!-KORDER,OLD!-KORDER;
  3602. NEW!-KORDER:=KERNORD(P,POLYZERO);
  3603. IF !*KERNREVERSE THEN NEW!-KORDER:=REVERSE NEW!-KORDER;
  3604. OLD!-KORDER:=SETKORDER NEW!-KORDER;
  3605. P:=REORDER P; % Make var of lowest degree the main one;
  3606. X:=FACTORIZE!-FORM1(P,NEW!-KORDER);
  3607. SETKORDER OLD!-KORDER;
  3608. N := CAR X;
  3609. X := FOR EACH P IN CDR X COLLECT (REORDER CAR P . CDR P);
  3610. IF MINUSP N THEN << S:=-1; N:=-N >> ELSE S:=1;
  3611. RES:=FOR EACH FF IN X COLLECT
  3612. IF POLY!-MINUSP CAR FF THEN <<
  3613. S:=S*(-1**CDR FF);
  3614. (NEGF CAR FF . CDR FF) >>
  3615. ELSE FF;
  3616. IF MINUSP S THEN ERRORF LIST(
  3617. "Stray minus sign in recursive factorisation:",X);
  3618. RETURN (N . RES)
  3619. END;
  3620. SYMBOLIC PROCEDURE SORT!-FACTORS L;
  3621. %sort factors as found into some sort of standard order. The order
  3622. %used here is more or less random, but will be self-consistent;
  3623. SORT(L,FUNCTION ORDERFACTORS);
  3624. %**********************************************************************;
  3625. % contents and primitive parts as applied to factorization;
  3626. SYMBOLIC PROCEDURE FACTORIZE!-BY!-CONTENTS(P,V);
  3627. %use contents wrt variables in list v to split the
  3628. %polynomial p. return a list of factors;
  3629. % specification is that on entry p *must* be positive;
  3630. IF DOMAINP P THEN
  3631. ERRORF LIST("FACTORIZE-BY-CONTENTS HANDED DOMAIN ELT:",P)
  3632. ELSE IF NULL V THEN SQUARE!.FREE!.FACTORIZE P
  3633. ELSE BEGIN SCALAR C,W,L,WTIME;
  3634. W:=CONTENTS!-WITH!-RESPECT!-TO(P,CAR V);
  3635. % contents!-with!-respect!-to returns a pair (g . c) where
  3636. % if g=nil the content is just c, otherwise g is a power
  3637. % [ x ** n ] and g*c is the content;
  3638. IF NOT NULL CAR W THEN <<
  3639. % here a power of v divides p;
  3640. L:=(!*K2F CAAR W . CDAR W) . NIL;
  3641. P:=QUOTFAIL(P,!*P2F CAR W);
  3642. IF P=1 THEN RETURN L
  3643. ELSE IF DOMAINP P THEN
  3644. ERRORF "P SHOULD NOT BE CONSTANT HERE" >>;
  3645. C:=CDR W;
  3646. IF C=1 THEN << %no progress here;
  3647. IF NULL L THEN
  3648. FACTOR!-TRACE << PRIN2!* "Polynomial is primitive wrt ";
  3649. PRINVAR CAR V; TERPRI!*(NIL) >>
  3650. ELSE FACTOR!-TRACE << PRINTSTR "Content is: ";
  3651. FAC!-PRINTFACTORS(1 . L) >>;
  3652. RETURN IF !*ALL!-CONTENTS THEN
  3653. APPEND(FACTORIZE!-BY!-CONTENTS(P,CDR V),L)
  3654. ELSE APPEND(SQUARE!.FREE!.FACTORIZE P,L) >>;
  3655. P:=QUOTFAIL(P,C); %primitive part;
  3656. % p is now primitive, so if it is not a real polynomial it
  3657. % must be a unit. since input was +ve it had better be +1 !! ;
  3658. IF P=-1 THEN
  3659. ERRORF "NEGATIVE PRIMITIVE PART IN FACTORIZE-BY-CONTENTS";
  3660. TRACE!-TIME PRINTC "Factoring the content:";
  3661. WTIME:=TIME();
  3662. L:=APPEND(CDR1 FACTORIZE!-FORM!-RECURSION C,L);
  3663. TRACE!-TIME DISPLAY!-TIME("Content factored in ",
  3664. TIME()-WTIME);
  3665. FACTOR!-TRACE <<
  3666. PRIN2!* "Content wrt "; PRINVAR CAR V; PRIN2!* " is: ";
  3667. FAC!-PRINTSF COMFAC!-TO!-POLY W;
  3668. PRINTSTR "Factors of content are: ";
  3669. FAC!-PRINTFACTORS(1 . L) >>;
  3670. IF P=1 THEN RETURN L
  3671. ELSE IF !*ALL!-CONTENTS THEN
  3672. RETURN APPEND(FACTORIZE!-BY!-CONTENTS(P,CDR V),L)
  3673. ELSE RETURN APPEND(SQUARE!.FREE!.FACTORIZE P,L)
  3674. END;
  3675. SYMBOLIC PROCEDURE CDR1 A;
  3676. IF CAR A=1 THEN CDR A
  3677. ELSE ERRORF LIST("NUMERIC CONTENT NOT EXTRACTED:",CAR A);
  3678. ENDMODULE;
  3679. MODULE FACUNI;
  3680. % *******************************************************************
  3681. %
  3682. % copyright (c) university of cambridge, england 1979
  3683. %
  3684. % *******************************************************************;
  3685. SYMBOLIC PROCEDURE UNIVARIATE!-FACTORIZE POLY;
  3686. % input poly a primitive square-free univariate polynomial at least
  3687. % quadratic and with +ve lc. output is a list of the factors of poly
  3688. % over the integers ;
  3689. IF TESTX!*!*N!+1 POLY THEN
  3690. FACTORIZEX!*!*N!+1(M!-IMAGE!-VARIABLE,LDEG POLY,1)
  3691. ELSE IF TESTX!*!*N!-1 POLY THEN
  3692. FACTORIZEX!*!*N!-1(M!-IMAGE!-VARIABLE,LDEG POLY,1)
  3693. ELSE UNIVARIATE!-FACTORIZE1 POLY;
  3694. SYMBOLIC PROCEDURE UNIVARIATE!-FACTORIZE1 POLY;
  3695. BEGIN SCALAR
  3696. VALID!-PRIMES,UNIVARIATE!-INPUT!-POLY,BEST!-SET!-POINTER,
  3697. NUMBER!-OF!-FACTORS,IRREDUCIBLE,FORBIDDEN!-PRIMES,
  3698. NO!-OF!-BEST!-PRIMES,NO!-OF!-RANDOM!-PRIMES,BAD!-CASE,
  3699. TARGET!-FACTOR!-COUNT,MODULAR!-INFO,UNIVARIATE!-FACTORS,
  3700. HENSEL!-GROWTH!-SIZE,ALPHALIST,PREVIOUS!-DEGREE!-MAP,
  3701. ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE,REDUCTION!-COUNT;
  3702. %note that this code works by using a local database of
  3703. %fluid variables that are updated by the subroutines directly
  3704. %called here. this allows for the relativly complicated
  3705. %interaction between flow of data and control that occurs in
  3706. %the factorization algorithm;
  3707. FACTOR!-TRACE <<
  3708. PRIN2!* "Univariate polynomial="; FAC!-PRINTSF POLY;
  3709. PRINTSTR
  3710. "The polynomial is univariate, primitive and square-free";
  3711. PRINTSTR "so we can treat it slightly more specifically. We";
  3712. PRINTSTR "factorise mod several primes,then pick the best one";
  3713. PRINTSTR "to use in the Hensel construction." >>;
  3714. INITIALIZE!-UNIVARIATE!-FLUIDS POLY;
  3715. % set up the fluids to start things off;
  3716. TRYAGAIN:
  3717. GET!-SOME!-RANDOM!-PRIMES();
  3718. CHOOSE!-THE!-BEST!-PRIME();
  3719. IF IRREDUCIBLE THEN <<
  3720. UNIVARIATE!-FACTORS:=LIST UNIVARIATE!-INPUT!-POLY;
  3721. GOTO EXIT >>
  3722. ELSE IF BAD!-CASE THEN <<
  3723. BAD!-CASE:=NIL; GOTO TRYAGAIN >>;
  3724. RECONSTRUCT!-FACTORS!-OVER!-INTEGERS();
  3725. IF IRREDUCIBLE THEN <<
  3726. UNIVARIATE!-FACTORS:=LIST UNIVARIATE!-INPUT!-POLY;
  3727. GOTO EXIT >>;
  3728. EXIT:
  3729. FACTOR!-TRACE <<
  3730. PRINTSTR "The univariate factors are:";
  3731. FOR EACH FF IN UNIVARIATE!-FACTORS DO FAC!-PRINTSF FF >>;
  3732. RETURN UNIVARIATE!-FACTORS
  3733. END;
  3734. %**********************************************************************
  3735. % univariate factorization part 1. initialization and setting fluids;
  3736. SYMBOLIC PROCEDURE INITIALIZE!-UNIVARIATE!-FLUIDS U;
  3737. % Set up the fluids to be used in factoring primitive poly;
  3738. BEGIN SCALAR W,W1;
  3739. IF !*FORCE!-PRIME THEN <<
  3740. NO!-OF!-RANDOM!-PRIMES:=1;
  3741. NO!-OF!-BEST!-PRIMES:=1 >>
  3742. ELSE <<
  3743. NO!-OF!-RANDOM!-PRIMES:=5;
  3744. % we generate this many modular images and calculate
  3745. % their factor counts;
  3746. NO!-OF!-BEST!-PRIMES:=3;
  3747. % we find the modular factors of this many;
  3748. >>;
  3749. UNIVARIATE!-INPUT!-POLY:=U;
  3750. TARGET!-FACTOR!-COUNT:=LDEG U
  3751. END;
  3752. %**********************************************************************;
  3753. % univariate factorization part 2. creating modular images and picking
  3754. % the best one;
  3755. SYMBOLIC PROCEDURE GET!-SOME!-RANDOM!-PRIMES();
  3756. % here we create a number of random primes to reduce the input mod p;
  3757. BEGIN SCALAR CHOSEN!-PRIME,POLY!-MOD!-P,I;
  3758. VALID!-PRIMES:=MKVECT NO!-OF!-RANDOM!-PRIMES;
  3759. I:=0;
  3760. WHILE I < NO!-OF!-RANDOM!-PRIMES DO <<
  3761. POLY!-MOD!-P:=
  3762. FIND!-A!-VALID!-PRIME(LC UNIVARIATE!-INPUT!-POLY,
  3763. UNIVARIATE!-INPUT!-POLY,NIL);
  3764. IF NOT(POLY!-MOD!-P='NOT!-SQUARE!-FREE) THEN <<
  3765. I:=IADD1 I;
  3766. PUTV(VALID!-PRIMES,I,CHOSEN!-PRIME . POLY!-MOD!-P);
  3767. FORBIDDEN!-PRIMES:=CHOSEN!-PRIME . FORBIDDEN!-PRIMES
  3768. >>
  3769. >>
  3770. END;
  3771. SYMBOLIC PROCEDURE CHOOSE!-THE!-BEST!-PRIME();
  3772. % given several random primes we now choose the best by factoring
  3773. % the poly mod its chosen prime and taking one with the
  3774. % lowest factor count as the best for hensel growth;
  3775. BEGIN SCALAR SPLIT!-LIST,POLY!-MOD!-P,NULL!-SPACE!-BASIS,
  3776. KNOWN!-FACTORS,W,N;
  3777. MODULAR!-INFO:=MKVECT NO!-OF!-RANDOM!-PRIMES;
  3778. FOR I:=1:NO!-OF!-RANDOM!-PRIMES DO <<
  3779. W:=GETV(VALID!-PRIMES,I);
  3780. GET!-FACTOR!-COUNT!-MOD!-P(I,CDR W,CAR W,NIL) >>;
  3781. SPLIT!-LIST:=SORT(SPLIT!-LIST,FUNCTION LESSPPAIR);
  3782. % this now contains a list of pairs (m . n) where
  3783. % m is the no: of factors in set no: n. the list
  3784. % is sorted with best split (smallest m) first;
  3785. IF CAAR SPLIT!-LIST = 1 THEN <<
  3786. IRREDUCIBLE:=T; RETURN NIL >>;
  3787. W:=SPLIT!-LIST;
  3788. FOR I:=1:NO!-OF!-BEST!-PRIMES DO <<
  3789. N:=CDAR W;
  3790. GET!-FACTORS!-MOD!-P(N,CAR GETV(VALID!-PRIMES,N));
  3791. W:=CDR W >>;
  3792. % pick the best few of these and find out their
  3793. % factors mod p;
  3794. SPLIT!-LIST:=DELETE(W,SPLIT!-LIST);
  3795. % throw away the other sets;
  3796. CHECK!-DEGREE!-SETS(NO!-OF!-BEST!-PRIMES,NIL);
  3797. % the best set is pointed at by best!-set!-pointer;
  3798. ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE:=T;
  3799. FACTOR!-TRACE <<
  3800. W:=GETV(VALID!-PRIMES,BEST!-SET!-POINTER);
  3801. PRIN2!* "The chosen prime is "; PRINTSTR CAR W;
  3802. PRIN2!* "The polynomial mod "; PRIN2!* CAR W;
  3803. PRINTSTR ", made monic, is:";
  3804. FAC!-PRINTSF CDR W;
  3805. PRINTSTR "and the factors of this modular polynomial are:";
  3806. FOR EACH X IN GETV(MODULAR!-INFO,BEST!-SET!-POINTER)
  3807. DO FAC!-PRINTSF X;
  3808. >>
  3809. END;
  3810. %**********************************************************************;
  3811. % univariate factorization part 3. reconstruction of the
  3812. % chosen image over the integers;
  3813. SYMBOLIC PROCEDURE RECONSTRUCT!-FACTORS!-OVER!-INTEGERS();
  3814. % the hensel construction from modular case to univariate
  3815. % over the integers;
  3816. BEGIN SCALAR BEST!-MODULUS,BEST!-FACTOR!-COUNT,INPUT!-POLYNOMIAL,
  3817. INPUT!-LEADING!-COEFFICIENT,BEST!-KNOWN!-FACTORS,S;
  3818. S:=GETV(VALID!-PRIMES,BEST!-SET!-POINTER);
  3819. BEST!-KNOWN!-FACTORS:=GETV(MODULAR!-INFO,BEST!-SET!-POINTER);
  3820. INPUT!-LEADING!-COEFFICIENT:=LC UNIVARIATE!-INPUT!-POLY;
  3821. BEST!-MODULUS:=CAR S;
  3822. BEST!-FACTOR!-COUNT:=LENGTH BEST!-KNOWN!-FACTORS;
  3823. INPUT!-POLYNOMIAL:=UNIVARIATE!-INPUT!-POLY;
  3824. UNIVARIATE!-FACTORS:=RECONSTRUCT!.OVER!.INTEGERS();
  3825. IF IRREDUCIBLE THEN RETURN T;
  3826. NUMBER!-OF!-FACTORS:=LENGTH UNIVARIATE!-FACTORS;
  3827. IF NUMBER!-OF!-FACTORS=1 THEN RETURN IRREDUCIBLE:=T
  3828. END;
  3829. SYMBOLIC PROCEDURE RECONSTRUCT!.OVER!.INTEGERS();
  3830. BEGIN SCALAR W,LCLIST,NON!-MONIC;
  3831. SET!-MODULUS BEST!-MODULUS;
  3832. FOR I:=1:BEST!-FACTOR!-COUNT DO
  3833. LCLIST:=INPUT!-LEADING!-COEFFICIENT . LCLIST;
  3834. IF NOT (INPUT!-LEADING!-COEFFICIENT=1) THEN <<
  3835. BEST!-KNOWN!-FACTORS:=
  3836. FOR EACH FF IN BEST!-KNOWN!-FACTORS COLLECT
  3837. MULTF(INPUT!-LEADING!-COEFFICIENT,!*MOD2F FF);
  3838. NON!-MONIC:=T;
  3839. FACTOR!-TRACE <<
  3840. PRINTSTR
  3841. "(a) Now the polynomial is not monic so we multiply each";
  3842. PRINTSTR
  3843. "of the modular factors, f(i), by the absolute value of";
  3844. PRIN2!* "the leading coefficient: ";
  3845. PRIN2!* INPUT!-LEADING!-COEFFICIENT; PRINTSTR '!.;
  3846. PRINTSTR "To bring the polynomial into agreement with this, we";
  3847. PRIN2!* "multiply it by ";
  3848. IF BEST!-FACTOR!-COUNT > 2 THEN
  3849. << PRIN2!* INPUT!-LEADING!-COEFFICIENT; PRIN2!* "**";
  3850. PRINTSTR ISUB1 BEST!-FACTOR!-COUNT >>
  3851. ELSE PRINTSTR INPUT!-LEADING!-COEFFICIENT >> >>;
  3852. W:=UHENSEL!.EXTEND(INPUT!-POLYNOMIAL,
  3853. BEST!-KNOWN!-FACTORS,LCLIST,BEST!-MODULUS);
  3854. IF IRREDUCIBLE THEN RETURN T;
  3855. IF CAR W ='OK THEN RETURN CDR W
  3856. ELSE ERRORF W
  3857. END;
  3858. % Now some special treatment for cyclotomic polynomials;
  3859. SYMBOLIC PROCEDURE TESTX!*!*N!+1 U;
  3860. NOT DOMAINP U AND (
  3861. LC U=1 AND
  3862. RED U = 1);
  3863. SYMBOLIC PROCEDURE TESTX!*!*N!-1 U;
  3864. NOT DOMAINP U AND (
  3865. LC U=1 AND
  3866. RED U = -1);
  3867. SYMBOLIC PROCEDURE FACTORIZEX!*!*N!+1(VAR,DEGREE,VORDER);
  3868. % Deliver factors of (VAR**VORDER)**DEGREE+1 given that it is
  3869. % appropriate to treat VAR**VORDER as a kernel;
  3870. IF EVENP DEGREE THEN FACTORIZEX!*!*N!+1(VAR,DEGREE/2,2*VORDER)
  3871. ELSE BEGIN
  3872. SCALAR W;
  3873. W := FACTORIZEX!*!*N!-1(VAR,DEGREE,VORDER);
  3874. W := NEGF CAR W . CDR W;
  3875. RETURN FOR EACH P IN W COLLECT NEGATE!-VARIABLE(VAR,2*VORDER,P)
  3876. END;
  3877. SYMBOLIC PROCEDURE NEGATE!-VARIABLE(VAR,VORDER,P);
  3878. % VAR**(VORDER/2) -> -VAR**(VORDER/2) in the polynomial P;
  3879. IF DOMAINP P THEN P
  3880. ELSE IF MVAR P=VAR THEN
  3881. IF REMAINDER(LDEG P,VORDER)=0 THEN
  3882. LT P .+ NEGATE!-VARIABLE(VAR,VORDER,RED P)
  3883. ELSE (LPOW P .* NEGF LC P) .+ NEGATE!-VARIABLE(VAR,VORDER,RED P)
  3884. ELSE (LPOW P .* NEGATE!-VARIABLE(VAR,VORDER,LC P)) .+
  3885. NEGATE!-VARIABLE(VAR,VORDER,RED P);
  3886. SYMBOLIC PROCEDURE INTEGER!-FACTORS N;
  3887. % Return integer factors of N, with attached multiplicities. Assumes
  3888. % that N is fairly small;
  3889. BEGIN
  3890. SCALAR L,Q,M,W;
  3891. % L is list of results generated so far, Q is current test divisor,
  3892. % and M is associated multiplicity;
  3893. IF N=1 THEN RETURN '((1 . 1));
  3894. Q := 2; M := 0;
  3895. TOP:
  3896. W := DIVIDE(N,Q);
  3897. WHILE CDR W=0 DO << N := CAR W; W := DIVIDE(N,Q); M := M+1 >>;
  3898. IF NOT M=0 THEN L := (Q . M) . L;
  3899. IF Q>CAR W THEN <<
  3900. IF NOT N=1 THEN L := (N . 1) . L;
  3901. RETURN REVERSEWOC L >>;
  3902. Q := ILOGOR(1,IADD1 Q); % Test divide by 2,3,5,7,9,11,13,... ;
  3903. M := 0;
  3904. GO TO TOP
  3905. END;
  3906. SYMBOLIC PROCEDURE FACTORED!-DIVISORS FL;
  3907. % FL is an association list of primes and exponents. Return a list
  3908. % of all subsets of this list, i.e. of numbers dividing the
  3909. % original integer. Exclude '1' from the list;
  3910. IF NULL FL THEN NIL
  3911. ELSE BEGIN
  3912. SCALAR L,W;
  3913. W := FACTORED!-DIVISORS CDR FL;
  3914. L := W;
  3915. FOR I := 1:CDAR FL DO <<
  3916. L := LIST (CAAR FL . I) . L;
  3917. FOR EACH P IN W DO
  3918. L := ((CAAR FL . I) . P) . L >>;
  3919. RETURN L
  3920. END;
  3921. SYMBOLIC PROCEDURE FACTORIZEX!*!*N!-1(VAR,DEGREE,VORDER);
  3922. IF EVENP DEGREE THEN APPEND(FACTORIZEX!*!*N!+1(VAR,DEGREE/2,VORDER),
  3923. FACTORIZEX!*!*N!-1(VAR,DEGREE/2,VORDER))
  3924. ELSE IF DEGREE=1 THEN LIST((MKSP(VAR,VORDER) .* 1) .+ (-1))
  3925. ELSE BEGIN
  3926. SCALAR FACDEG,L;
  3927. FACDEG := '((1 . 1)) . FACTORED!-DIVISORS INTEGER!-FACTORS DEGREE;
  3928. RETURN FOR EACH FL IN FACDEG
  3929. COLLECT CYCLOTOMIC!-POLYNOMIAL(VAR,FL,VORDER)
  3930. END;
  3931. SYMBOLIC PROCEDURE CYCLOTOMIC!-POLYNOMIAL(VAR,FL,VORDER);
  3932. % Create Psi<degree>(var**order)
  3933. % where degree is given by the association list of primes and
  3934. % multiplicities FL;
  3935. IF NOT CDAR FL=1 THEN
  3936. CYCLOTOMIC!-POLYNOMIAL(VAR,(CAAR FL . SUB1 CDAR FL) . CDR FL,
  3937. VORDER*CAAR FL)
  3938. ELSE IF CDR FL=NIL THEN
  3939. IF CAAR FL=1 THEN (MKSP(VAR,VORDER) .* 1) .+ (-1)
  3940. ELSE QUOTFAIL((MKSP(VAR,VORDER*CAAR FL) .* 1) .+ (-1),
  3941. (MKSP(VAR,VORDER) .* 1) .+ (-1))
  3942. ELSE QUOTFAIL(CYCLOTOMIC!-POLYNOMIAL(VAR,CDR FL,VORDER*CAAR FL),
  3943. CYCLOTOMIC!-POLYNOMIAL(VAR,CDR FL,VORDER));
  3944. ENDMODULE;
  3945. MODULE IMAGESET;
  3946. % *******************************************************************
  3947. %
  3948. % copyright (c) university of cambridge, england 1979
  3949. %
  3950. % *******************************************************************;
  3951. %*******************************************************************;
  3952. %
  3953. % this section deals with the image sets used in
  3954. % factorising multivariate polynomials according
  3955. % to wang's theories.
  3956. % ref: math. comp. vol.32 no.144 oct 1978 pp 1217-1220
  3957. % 'an improved multivariate polynomial factoring algorithm'
  3958. %
  3959. %*******************************************************************;
  3960. %*******************************************************************;
  3961. % first we have routines for generating the sets
  3962. %*******************************************************************;
  3963. SYMBOLIC PROCEDURE GENERATE!-AN!-IMAGE!-SET!-WITH!-PRIME
  3964. GOOD!-SET!-NEEDED;
  3965. % given a multivariate poly (in a fluid) we generate an image set
  3966. % to make it univariate and also a random prime to use in the
  3967. % modular factorization. these numbers are random except that
  3968. % we will not allow anything in forbidden!-sets or forbidden!-primes;
  3969. BEGIN SCALAR CURRENTLY!-FORBIDDEN!-SETS,U,WTIME;
  3970. U:=MULTIVARIATE!-INPUT!-POLY;
  3971. % a bit of a handful to type otherwise!!!! ;
  3972. IMAGE!-SET:=NIL;
  3973. CURRENTLY!-FORBIDDEN!-SETS:=FORBIDDEN!-SETS;
  3974. TRYANOTHERSET:
  3975. IF IMAGE!-SET THEN
  3976. CURRENTLY!-FORBIDDEN!-SETS:=IMAGE!-SET .
  3977. CURRENTLY!-FORBIDDEN!-SETS;
  3978. WTIME:=TIME();
  3979. IMAGE!-SET:=GET!-NEW!-SET CURRENTLY!-FORBIDDEN!-SETS;
  3980. % PRINC "Trying imageset= ";
  3981. % PRINTC IMAGE!-SET;
  3982. TRACE!-TIME <<
  3983. DISPLAY!-TIME(" New image set found in ",TIME()-WTIME);
  3984. WTIME:=TIME() >>;
  3985. IMAGE!-LC:=MAKE!-IMAGE!-LC!-LIST(LC U,IMAGE!-SET);
  3986. % list of image lc's wrt different variables in IMAGE-SET;
  3987. % PRINC "Image set to try is:";% PRINTC IMAGE!-SET;
  3988. % PRIN2!* "L.C. of poly is:";% FAC!-PRINTSF LC U;
  3989. % PRINTC "Image l.c.s with variables substituted on order:";
  3990. % FOR EACH IMLC IN IMAGE!-LC DO FAC!-PRINTSF IMLC;
  3991. TRACE!-TIME
  3992. DISPLAY!-TIME(" Image of lc made in ",TIME()-WTIME);
  3993. IF (CAAR IMAGE!-LC)=0 THEN GOTO TRYANOTHERSET;
  3994. WTIME:=TIME();
  3995. IMAGE!-POLY:=MAKE!-IMAGE(U,IMAGE!-SET);
  3996. TRACE!-TIME <<
  3997. DISPLAY!-TIME(" Image poly made in ",TIME()-WTIME);
  3998. WTIME:=TIME() >>;
  3999. IMAGE!-CONTENT:=GET!.CONTENT IMAGE!-POLY;
  4000. % note: the content contains the image variable if it
  4001. % is a factor of the image poly;
  4002. TRACE!-TIME
  4003. DISPLAY!-TIME(" Content found in ",TIME()-WTIME);
  4004. IMAGE!-POLY:=QUOTFAIL(IMAGE!-POLY,IMAGE!-CONTENT);
  4005. % make sure the image polynomial is primitive which includes
  4006. % making the leading coefft positive (-ve content if
  4007. % necessary);
  4008. WTIME:=TIME();
  4009. IMAGE!-MOD!-P:=FIND!-A!-VALID!-PRIME(IMAGE!-LC,IMAGE!-POLY,
  4010. NOT NUMBERP IMAGE!-CONTENT);
  4011. IF IMAGE!-MOD!-P='NOT!-SQUARE!-FREE THEN GOTO TRYANOTHERSET;
  4012. TRACE!-TIME <<
  4013. DISPLAY!-TIME(" Prime and image mod p found in ",TIME()-WTIME);
  4014. WTIME:=TIME() >>;
  4015. IF FACTORED!-LC THEN
  4016. IF F!-NUMVEC:=UNIQUE!-F!-NOS(FACTORED!-LC,IMAGE!-CONTENT,
  4017. IMAGE!-SET) THEN <<
  4018. USABLE!-SET!-FOUND:=T;
  4019. TRACE!-TIME
  4020. DISPLAY!-TIME(" Nos for lc found in ",TIME()-WTIME) >>
  4021. ELSE <<
  4022. TRACE!-TIME DISPLAY!-TIME(" Nos for lc failed in ",
  4023. TIME()-WTIME);
  4024. IF (NOT USABLE!-SET!-FOUND) AND GOOD!-SET!-NEEDED THEN
  4025. GOTO TRYANOTHERSET >>
  4026. END;
  4027. SYMBOLIC PROCEDURE GET!-NEW!-SET FORBIDDEN!-S;
  4028. % associate each variable in vars-to-kill with a random no. mod
  4029. % image-set-modulus. If the boolean tagged with a variable is true then
  4030. % a value of 1 or 0 is no good and so rejected, however all other
  4031. % variables can take these values so they are tried exhaustively before
  4032. % using truly random values. sets in forbidden!-s not allowed;
  4033. BEGIN SCALAR OLD!.M,ALIST,N,NEXTZSET,W;
  4034. IF ZERO!-SET!-TRIED THEN <<
  4035. IF !*FORCE!-ZERO!-SET THEN
  4036. ERRORF "Zero set tried - possibly it was invalid";
  4037. IMAGE!-SET!-MODULUS:=IADD1 IMAGE!-SET!-MODULUS;
  4038. OLD!.M:=SET!-MODULUS IMAGE!-SET!-MODULUS;
  4039. ALIST:=FOR EACH V IN VARS!-TO!-KILL COLLECT
  4040. << N:=MODULAR!-NUMBER RANDOM();
  4041. IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS;
  4042. IF CDR V THEN <<
  4043. WHILE N=0
  4044. OR N=1
  4045. OR (N = (ISUB1 CURRENT!-MODULUS)) DO
  4046. N:=MODULAR!-NUMBER RANDOM();
  4047. IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS >>;
  4048. CAR V . N >> >>
  4049. ELSE <<
  4050. OLD!.M:=SET!-MODULUS IMAGE!-SET!-MODULUS;
  4051. NEXTZSET:=CAR ZSET;
  4052. ALIST:=FOR EACH ZV IN ZEROVARSET COLLECT <<
  4053. W:=ZV . CAR NEXTZSET;
  4054. NEXTZSET:=CDR NEXTZSET;
  4055. W >>;
  4056. IF OTHERVARS THEN ALIST:=
  4057. APPEND(ALIST,FOR EACH V IN OTHERVARS COLLECT <<
  4058. N:=MODULAR!-NUMBER RANDOM();
  4059. WHILE N=0
  4060. OR N=1
  4061. OR (N = (ISUB1 CURRENT!-MODULUS)) DO
  4062. N:=MODULAR!-NUMBER RANDOM();
  4063. IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS;
  4064. V . N >>);
  4065. IF NULL(ZSET:=CDR ZSET) THEN
  4066. IF NULL SAVE!-ZSET THEN ZERO!-SET!-TRIED:=T
  4067. ELSE ZSET:=MAKE!-NEXT!-ZSET SAVE!-ZSET;
  4068. ALIST:=FOR EACH V IN CDR KORD!* COLLECT ATSOC(V,ALIST);
  4069. % Puts the variables in alist in the right order;
  4070. >>;
  4071. SET!-MODULUS OLD!.M;
  4072. RETURN IF MEMBER(ALIST,FORBIDDEN!-S) THEN
  4073. GET!-NEW!-SET FORBIDDEN!-S
  4074. ELSE ALIST
  4075. END;
  4076. %**********************************************************************
  4077. % now given an image/univariate polynomial find a suitable random prime;
  4078. SYMBOLIC PROCEDURE FIND!-A!-VALID!-PRIME(LC!-U,U,FACTOR!-X);
  4079. % finds a suitable random prime for reducing a poly mod p.
  4080. % u is the image/univariate poly. we are not allowed to use
  4081. % any of the primes in forbidden!-primes (fluid).
  4082. % lc!-u is either numeric or (in the multivariate case) a list of
  4083. % images of the lc;
  4084. BEGIN SCALAR CURRENTLY!-FORBIDDEN!-PRIMES,RES,PRIME!-COUNT,V,W;
  4085. IF FACTOR!-X THEN U:=MULTF(U,V:=!*K2F M!-IMAGE!-VARIABLE);
  4086. CHOSEN!-PRIME:=NIL;
  4087. CURRENTLY!-FORBIDDEN!-PRIMES:=FORBIDDEN!-PRIMES;
  4088. PRIME!-COUNT:=1;
  4089. TRYANOTHERPRIME:
  4090. IF CHOSEN!-PRIME THEN
  4091. CURRENTLY!-FORBIDDEN!-PRIMES:=CHOSEN!-PRIME .
  4092. CURRENTLY!-FORBIDDEN!-PRIMES;
  4093. CHOSEN!-PRIME:=GET!-NEW!-PRIME CURRENTLY!-FORBIDDEN!-PRIMES;
  4094. SET!-MODULUS CHOSEN!-PRIME;
  4095. IF NOT ATOM LC!-U THEN <<
  4096. W:=LC!-U;
  4097. WHILE W AND
  4098. ((DOMAINP CAAR W AND NOT(MODULAR!-NUMBER CAAR W = 0))
  4099. OR NOT (DOMAINP CAAR W OR
  4100. MODULAR!-NUMBER L!-NUMERIC!-C(CAAR W,CDAR W)=0)) DO
  4101. W:=CDR W;
  4102. IF W THEN GOTO TRYANOTHERPRIME >>
  4103. ELSE IF MODULAR!-NUMBER LC!-U=0 THEN GOTO TRYANOTHERPRIME;
  4104. RES:=MONIC!-MOD!-P REDUCE!-MOD!-P U;
  4105. IF NOT SQUARE!-FREE!-MOD!-P RES THEN
  4106. IF MULTIVARIATE!-INPUT!-POLY
  4107. AND (PRIME!-COUNT:=PRIME!-COUNT+1)>5 THEN
  4108. RES:='NOT!-SQUARE!-FREE
  4109. ELSE GOTO TRYANOTHERPRIME;
  4110. IF FACTOR!-X AND NOT(RES='NOT!-SQUARE!-FREE) THEN
  4111. RES:=QUOTFAIL!-MOD!-P(RES,!*F2MOD V);
  4112. RETURN RES
  4113. END;
  4114. SYMBOLIC PROCEDURE GET!-NEW!-PRIME FORBIDDEN!-P;
  4115. % get a small prime that is not in the list forbidden!-p;
  4116. % we pick one of the first 10 primes if we can;
  4117. IF !*FORCE!-PRIME THEN !*FORCE!-PRIME
  4118. ELSE BEGIN SCALAR P,PRIMES!-DONE;
  4119. FOR EACH PP IN FORBIDDEN!-P DO
  4120. IF PP<32 THEN PRIMES!-DONE:=PP.PRIMES!-DONE;
  4121. TRYAGAIN:
  4122. IF NULL(P:=RANDOM!-TEENY!-PRIME PRIMES!-DONE) THEN <<
  4123. P:=RANDOM!-SMALL!-PRIME();
  4124. PRIMES!-DONE:='ALL >>
  4125. ELSE PRIMES!-DONE:=P . PRIMES!-DONE;
  4126. IF MEMBER(P,FORBIDDEN!-P) THEN GOTO TRYAGAIN;
  4127. RETURN P
  4128. END;
  4129. %***********************************************************************
  4130. % find the numbers associated with each factor of the leading
  4131. % coefficient of our multivariate polynomial. this will help
  4132. % to distribute the leading coefficient later.;
  4133. SYMBOLIC PROCEDURE UNIQUE!-F!-NOS(V,CONT!.U0,IM!.SET);
  4134. % given an image set (im!.set), this finds the numbers associated with
  4135. % each factor in v subject to wang's condition (2) on the image set.
  4136. % this is an implementation of his algorithm n. if the condition
  4137. % is met the result is a vector containing the images of each factor
  4138. % in v, otherwise the result is nil;
  4139. BEGIN SCALAR D,K,Q,R,LC!.IMAGE!.VEC;
  4140. % v's integer factor is at the front: ;
  4141. K:=LENGTH CDR V;
  4142. % no. of non-trivial factors of v;
  4143. IF NOT NUMBERP CONT!.U0 THEN CONT!.U0:=LC CONT!.U0;
  4144. PUTV(D:=MKVECT K,0,ABS(CONT!.U0 * CAR V));
  4145. % d will contain the special numbers to be used in the
  4146. % loop below;
  4147. PUTV(LC!.IMAGE!.VEC:=MKVECT K,0,ABS(CONT!.U0 * CAR V));
  4148. % vector for result with 0th entry filled in;
  4149. V:=CDR V;
  4150. % throw away integer factor of v;
  4151. % k is no. of non-trivial factors (say f(i)) in v;
  4152. % d will contain the nos. associated with each f(i);
  4153. % v is now a list of the f(i) (and their multiplicities);
  4154. FOR I:=1:K DO
  4155. << Q:=ABS MAKE!-IMAGE(CAAR V,IM!.SET);
  4156. PUTV(LC!.IMAGE!.VEC,I,Q);
  4157. V:=CDR V;
  4158. FOR J:=ISUB1 I STEP -1 UNTIL 0 DO
  4159. << R:=GETV(D,J);
  4160. WHILE NOT ONEP R DO
  4161. << R:=GCD(R,Q); Q:=Q/R >>;
  4162. IF ONEP Q THEN RETURN LC!.IMAGE!.VEC:=NIL;
  4163. % if q=1 here then we have failed the condition so exit;
  4164. >>;
  4165. IF NULL LC!.IMAGE!.VEC THEN RETURN LC!.IMAGE!.VEC;
  4166. PUTV(D,I,Q);
  4167. % else q is the ith number we want;
  4168. >>;
  4169. RETURN LC!.IMAGE!.VEC
  4170. END;
  4171. SYMBOLIC PROCEDURE GET!.CONTENT U;
  4172. % u is a univariate square free poly. gets the content of u (=integer);
  4173. % if lc u is negative then the minus sign is pulled out as well;
  4174. % nb. the content includes the variable if it is a factor of u;
  4175. BEGIN SCALAR C;
  4176. C:=IF POLY!-MINUSP U THEN -(NUMERIC!-CONTENT U)
  4177. ELSE NUMERIC!-CONTENT U;
  4178. IF NOT DIDNTGO QUOTF(U,!*K2F M!-IMAGE!-VARIABLE) THEN
  4179. C:=ADJOIN!-TERM(MKSP(M!-IMAGE!-VARIABLE,1),C,POLYZERO);
  4180. RETURN C
  4181. END;
  4182. %********************************************************************;
  4183. % finally we have the routines that use the numbers generated
  4184. % by unique.f.nos to determine the true leading coeffts in
  4185. % the multivariate factorization we are doing and which image
  4186. % factors will grow up to have which true leading coefft.
  4187. %********************************************************************;
  4188. SYMBOLIC PROCEDURE DISTRIBUTE!.LC(R,IM!.FACTORS,S,V);
  4189. % v is the factored lc of a poly, say u, whose image factors (r of
  4190. % them) are in the vector im.factors. s is a list containing the
  4191. % image information including the image set, the image poly etc.
  4192. % this uses wang's ideas for distributing the factors in v over
  4193. % those in im.factors. result is (delta . vector of the lc's of
  4194. % the full factors of u) , where delta is the remaining integer part
  4195. % of the lc that we have been unable to distribute. ;
  4196. (LAMBDA FACTOR!-LEVEL;
  4197. BEGIN SCALAR K,DELTA,DIV!.COUNT,Q,UF,I,D,MAX!.MULT,F,NUMVEC,
  4198. DVEC,WVEC,DTWID,W;
  4199. DELTA:=GET!-IMAGE!-CONTENT S;
  4200. % the content of the u image poly;
  4201. DIST!.LC!.MSG1(DELTA,IM!.FACTORS,R,S,V);
  4202. V:=CDR V;
  4203. % we are not interested in the numeric factors of v;
  4204. K:=LENGTH V;
  4205. % number of things to distribute;
  4206. NUMVEC:=GET!-F!-NUMVEC S;
  4207. % nos. associated with factors in v;
  4208. DVEC:=MKVECT R;
  4209. WVEC:=MKVECT R;
  4210. FOR J:=1:R DO <<
  4211. PUTV(DVEC,J,1);
  4212. PUTV(WVEC,J,DELTA*LC GETV(IM!.FACTORS,J)) >>;
  4213. % result lc's will go into dvec which we initialize to 1's;
  4214. % wvec is a work vector that we use in the division process
  4215. % below;
  4216. V:=REVERSE V;
  4217. FOR J:=K STEP -1 UNTIL 1 DO
  4218. << % (for each factor in v, call it f(j) );
  4219. F:=CAAR V;
  4220. % f(j) itself;
  4221. MAX!.MULT:=CDAR V;
  4222. % multiplicity of f(j) in v (=lc u);
  4223. V:=CDR V;
  4224. D:=GETV(NUMVEC,J);
  4225. % number associated with f(j);
  4226. I:=1; % we trial divide d into lc of each image
  4227. % factor starting with 1st;
  4228. DIV!.COUNT:=0;
  4229. % no. of d's that have been distributed;
  4230. FACTOR!-TRACE <<
  4231. PRIN2!* "f("; PRIN2!* J; PRIN2!* ")= "; FAC!-PRINTSF F;
  4232. PRIN2!* "There are "; PRIN2!* MAX!.MULT;
  4233. PRINTSTR " of these in the leading coefficient.";
  4234. PRIN2!* "The absolute value of the image of f("; PRIN2!* J;
  4235. PRIN2!* ")= "; PRINTSTR D >>;
  4236. WHILE ILESSP(DIV!.COUNT,MAX!.MULT)
  4237. AND NOT IGREATERP(I,R) DO
  4238. << Q:=DIVIDE(GETV(WVEC,I),D);
  4239. % first trial division;
  4240. FACTOR!-TRACE <<
  4241. PRIN2!* " Trial divide into ";
  4242. PRIN2!* GETV(WVEC,I); PRINTSTR " :" >>;
  4243. WHILE (ZEROP CDR Q) AND ILESSP(DIV!.COUNT,MAX!.MULT) DO
  4244. << PUTV(DVEC,I,MULTF(GETV(DVEC,I),F));
  4245. % f(j) belongs in lc of ith factor;
  4246. FACTOR!-TRACE <<
  4247. PRIN2!* " It goes so an f("; PRIN2!* J;
  4248. PRIN2!* ") belongs in ";
  4249. FAC!-PRINTSF GETV(IM!.FACTORS,I);
  4250. PRINTSTR " Try again..." >>;
  4251. DIV!.COUNT:=IADD1 DIV!.COUNT;
  4252. % another d done;
  4253. PUTV(WVEC,I,CAR Q);
  4254. % save the quotient for next factor to distribute;
  4255. Q:=DIVIDE(CAR Q,D);
  4256. % try again;
  4257. >>;
  4258. I:=IADD1 I;
  4259. % as many d's as possible have gone into that
  4260. % factor so now try next factor;
  4261. FACTOR!-TRACE <<
  4262. PRINTSTR " no good so try another factor ..." >>
  4263. >>;
  4264. % at this point the whole of f(j) should have been
  4265. % distributed by dividing d the maximum no. of times
  4266. % (= max!.mult), otherwise we have an extraneous factor;
  4267. IF ILESSP(DIV!.COUNT,MAX!.MULT) THEN
  4268. RETURN BAD!-CASE:=T
  4269. >>;
  4270. IF BAD!-CASE THEN RETURN;
  4271. FACTOR!-TRACE <<
  4272. PRINTSTR "The leading coefficients are now correct to within an";
  4273. PRINTSTR "integer factor and are as follows:";
  4274. FOR J:=1:R DO <<
  4275. PRINSF GETV(IM!.FACTORS,J);
  4276. PRIN2!* " with l.c. ";
  4277. FAC!-PRINTSF GETV(DVEC,J) >> >>;
  4278. IF ONEP DELTA THEN
  4279. << FOR J:=1:R DO <<
  4280. W:=LC GETV(IM!.FACTORS,J) /
  4281. EVALUATE!-IN!-ORDER(GETV(DVEC,J),GET!-IMAGE!-SET S);
  4282. IF W<0 THEN BEGIN
  4283. SCALAR OLDPOLY;
  4284. DELTA:= -DELTA;
  4285. OLDPOLY:=GETV(IM!.FACTORS,J);
  4286. PUTV(IM!.FACTORS,J,NEGF OLDPOLY);
  4287. % to keep the leading coefficients positive we negate the
  4288. % image factors when necessary;
  4289. MULTIPLY!-ALPHAS(-1,OLDPOLY,GETV(IM!.FACTORS,J));
  4290. % remember to fix the alphas as well;
  4291. END;
  4292. PUTV(DVEC,J,MULTF(ABS W,GETV(DVEC,J))) >>;
  4293. DIST!.LC!.MSG2(DVEC,IM!.FACTORS,R);
  4294. RETURN (DELTA . DVEC)
  4295. >>;
  4296. % if delta=1 then we know the true lc's exactly so put in their
  4297. % integer contents and return with result.
  4298. % otherwise try spreading delta out over the factors: ;
  4299. FACTOR!-TRACE <<
  4300. PRIN2!* " Here delta is not 1 meaning that we have a content, ";
  4301. PRINTSTR DELTA;
  4302. PRINTSTR "of the image to distribute among the factors somehow.";
  4303. PRINTSTR "For each IM-factor we can divide its leading";
  4304. PRINTSTR "coefficient by the image of its determined leading";
  4305. PRINTSTR "coefficient and see if there is a non-trivial result.";
  4306. PRINTSTR "This will indicate a factor of delta belonging to this";
  4307. PRINTSTR "IM-factor's leading coefficient." >>;
  4308. FOR J:=1:R DO
  4309. << DTWID:=EVALUATE!-IN!-ORDER(GETV(DVEC,J),GET!-IMAGE!-SET S);
  4310. UF:=GETV(IM!.FACTORS,J);
  4311. D:=GCD(LC UF,DTWID);
  4312. PUTV(DVEC,J,MULTF(LC UF/D,GETV(DVEC,J)));
  4313. PUTV(IM!.FACTORS,J,MULTF(DTWID/D,UF));
  4314. % have to fiddle the image factors by an integer multiple;
  4315. MULTIPLY!-ALPHAS!-RECIP(DTWID/D,UF,GETV(IM!.FACTORS,J));
  4316. % fix the alphas;
  4317. DELTA:=DELTA/(DTWID/D)
  4318. >>;
  4319. % now we've done all we can to distribute delta so we return with
  4320. % what's left: ;
  4321. IF DELTA<=0 THEN
  4322. ERRORF LIST("FINAL DELTA IS -VE IN DISTRIBUTE!.LC",DELTA);
  4323. FACTOR!-TRACE <<
  4324. PRINTSTR " Finally we have:";
  4325. FOR J:=1:R DO <<
  4326. PRINSF GETV(IM!.FACTORS,J);
  4327. PRIN2!* " with l.c. ";
  4328. FAC!-PRINTSF GETV(DVEC,J) >> >>;
  4329. RETURN (DELTA . DVEC)
  4330. END) (FACTOR!-LEVEL * 10);
  4331. SYMBOLIC PROCEDURE DIST!.LC!.MSG1(DELTA,IM!.FACTORS,R,S,V);
  4332. FACTOR!-TRACE <<
  4333. TERPRI(); TERPRI();
  4334. PRINTSTR "We have a polynomial whose image factors (call";
  4335. PRINTSTR "them the IM-factors) are:";
  4336. PRIN2!* DELTA; PRINTSTR " (= numeric content, delta)";
  4337. PRINTVEC(" f(",R,")= ",IM!.FACTORS);
  4338. PRIN2!* " wrt the image set: ";
  4339. FOR EACH X IN GET!-IMAGE!-SET S DO <<
  4340. PRINVAR CAR X; PRIN2!* "="; PRIN2!* CDR X; PRIN2!* ";" >>;
  4341. TERPRI!*(NIL);
  4342. PRINTSTR "We also have its true multivariate leading";
  4343. PRINTSTR "coefficient whose factors (call these the";
  4344. PRINTSTR "LC-factors) are:";
  4345. FAC!-PRINTFACTORS V;
  4346. PRINTSTR "We want to determine how these LC-factors are";
  4347. PRINTSTR "distributed over the leading coefficients of each";
  4348. PRINTSTR "IM-factor. This enables us to feed the resulting";
  4349. PRINTSTR "image factors into a multivariate Hensel";
  4350. PRINTSTR "construction.";
  4351. PRINTSTR "We distribute each LC-factor in turn by dividing";
  4352. PRINTSTR "its image into delta times the leading coefficient";
  4353. PRINTSTR "of each IM-factor until it finds one that it";
  4354. PRINTSTR "divides exactly. The image set is chosen such that";
  4355. PRINTSTR "this will only happen for the IM-factors to which";
  4356. PRINTSTR "this LC-factor belongs - (there may be more than";
  4357. PRINTSTR "one if the LC-factor occurs several times in the";
  4358. PRINTSTR "leading coefficient of the original polynomial).";
  4359. PRINTSTR "This choice also requires that we distribute the";
  4360. PRINTSTR "LC-factors in a specific order:"
  4361. >>;
  4362. SYMBOLIC PROCEDURE DIST!.LC!.MSG2(DVEC,IM!.FACTORS,R);
  4363. FACTOR!-TRACE <<
  4364. PRINTSTR "Since delta=1, we have no non-trivial content of the";
  4365. PRINTSTR
  4366. "image to deal with so we know the true leading coefficients";
  4367. PRINTSTR
  4368. "exactly. We fix the signs of the IM-factors to match those";
  4369. PRINTSTR "of their true leading coefficients:";
  4370. FOR J:=1:R DO <<
  4371. PRINSF GETV(IM!.FACTORS,J);
  4372. PRIN2!* " with l.c. ";
  4373. FAC!-PRINTSF GETV(DVEC,J) >> >>;
  4374. ENDMODULE;
  4375. MODULE INTERFAC;
  4376. %**********************************************************************;
  4377. %
  4378. % copyright (c) university of cambridge, england 1981
  4379. %
  4380. %**********************************************************************;
  4381. %**********************************************************************;
  4382. % Routines that are specific to REDUCE.
  4383. % These are either routines that are not needed in the HASH system
  4384. % (which is the other algebra system that this factorizer
  4385. % can be plugged into) or routines that are specifically
  4386. % redefined in the HASH system. ;
  4387. %---------------------------------------------------------------------;
  4388. % The following would normally live in section: ALPHAS
  4389. %---------------------------------------------------------------------;
  4390. SYMBOLIC PROCEDURE ASSOC!-ALPHA(POLY,ALIST); ASSOC(POLY,ALIST);
  4391. %---------------------------------------------------------------------;
  4392. % The following would normally live in section: COEFFTS
  4393. %---------------------------------------------------------------------;
  4394. SYMBOLIC PROCEDURE TERMVECTOR2SF V;
  4395. BEGIN SCALAR R,W;
  4396. FOR I:=CAR GETV(V,0) STEP -1 UNTIL 1 DO <<
  4397. W:=GETV(V,I);
  4398. % degree . coefft;
  4399. R:=IF CAR W=0 THEN CDR W ELSE
  4400. (MKSP(M!-IMAGE!-VARIABLE,CAR W) .* CDR W) .+ R
  4401. >>;
  4402. RETURN R
  4403. END;
  4404. SYMBOLIC PROCEDURE FORCE!-LC(A,N);
  4405. % force polynomial a to have leading coefficient as specified;
  4406. (LPOW A .* N) .+ RED A;
  4407. SYMBOLIC PROCEDURE MERGE!-TERMS(U,V);
  4408. MERGE!-TERMS1(1,U,V,CAR GETV(V,0));
  4409. SYMBOLIC PROCEDURE MERGE!-TERMS1(I,U,V,N);
  4410. IF I#>N THEN U
  4411. ELSE BEGIN SCALAR A,B;
  4412. A:=GETV(V,I);
  4413. IF DOMAINP U OR NOT(MVAR U=M!-IMAGE!-VARIABLE) THEN
  4414. IF NOT(CAR A=0) THEN ERRORF LIST("MERGING COEFFTS FAILED",U,A)
  4415. ELSE IF CDR A THEN RETURN CDR A
  4416. ELSE RETURN U;
  4417. B:=LT U;
  4418. IF TDEG B=CAR A THEN RETURN
  4419. (IF CDR A THEN TPOW B .* CDR A ELSE B) .+
  4420. MERGE!-TERMS1(I #+ 1,RED U,V,N)
  4421. ELSE IF TDEG B #> CAR A THEN RETURN B .+ MERGE!-TERMS1(I,RED U,V,N)
  4422. ELSE ERRORF LIST("MERGING COEFFTS FAILED ",U,A)
  4423. END;
  4424. SYMBOLIC PROCEDURE LIST!-TERMS!-IN!-FACTOR U;
  4425. % ...;
  4426. IF DOMAINP U THEN LIST (0 . NIL)
  4427. ELSE (LDEG U . NIL) . LIST!-TERMS!-IN!-FACTOR RED U;
  4428. SYMBOLIC PROCEDURE TRY!-OTHER!-COEFFTS(R,UNKNOWNS!-LIST,UV);
  4429. BEGIN SCALAR LDEG!-R,LC!-R,W;
  4430. WHILE NOT DOMAINP R AND (R:=RED R) AND NOT(W='COMPLETE) DO <<
  4431. IF NOT DEPENDS!-ON!-VAR(R,M!-IMAGE!-VARIABLE) THEN
  4432. << LDEG!-R:=0; LC!-R:=R >>
  4433. ELSE << LDEG!-R:=LDEG R; LC!-R:=LC R >>;
  4434. W:=SOLVE!-NEXT!-COEFFT(LDEG!-R,LC!-R,UNKNOWNS!-LIST,UV) >>
  4435. END;
  4436. %---------------------------------------------------------------------;
  4437. % The following would normally live in section: FACMISC
  4438. %---------------------------------------------------------------------;
  4439. SYMBOLIC PROCEDURE DERIVATIVE!-WRT!-MAIN!-VARIABLE(P,VAR);
  4440. % partial derivative of the polynomial p with respect to
  4441. % its main variable, var;
  4442. IF DOMAINP P OR (MVAR P NEQ VAR) THEN NIL
  4443. ELSE
  4444. BEGIN
  4445. SCALAR DEGREE;
  4446. DEGREE:=LDEG P;
  4447. IF DEGREE=1 THEN RETURN LC P; %degree one term is special;
  4448. RETURN (MKSP(MVAR P,DEGREE-1) .* MULTF(DEGREE,LC P)) .+
  4449. DERIVATIVE!-WRT!-MAIN!-VARIABLE(RED P,VAR)
  4450. END;
  4451. SYMBOLIC PROCEDURE UNIVARIATEP U;
  4452. % tests to see if u is univariate;
  4453. DOMAINP U OR NOT MULTIVARIATEP(U,MVAR U);
  4454. SYMBOLIC PROCEDURE VARIABLES!.IN!.FORM(A,SOFAR);
  4455. IF DOMAINP A THEN SOFAR
  4456. ELSE <<
  4457. IF NOT MEMQ(MVAR A,SOFAR) THEN
  4458. SOFAR:=MVAR A . SOFAR;
  4459. VARIABLES!.IN!.FORM(RED A,
  4460. VARIABLES!.IN!.FORM(LC A,SOFAR)) >>;
  4461. SYMBOLIC PROCEDURE DEGREE!-IN!-VARIABLE(P,V);
  4462. % returns the degree of the polynomial p in the
  4463. % variable v;
  4464. IF DOMAINP P THEN 0
  4465. ELSE IF LC P=0
  4466. THEN ERRORF "Polynomial with a zero coefficient found"
  4467. ELSE IF V=MVAR P THEN LDEG P
  4468. ELSE MAX(DEGREE!-IN!-VARIABLE(LC P,V),
  4469. DEGREE!-IN!-VARIABLE(RED P,V));
  4470. SYMBOLIC PROCEDURE GET!-HEIGHT POLY;
  4471. % find height (max coefft) of given poly;
  4472. IF NULL POLY THEN 0
  4473. ELSE IF NUMBERP POLY THEN ABS POLY
  4474. ELSE MAX(GET!-HEIGHT LC POLY,GET!-HEIGHT RED POLY);
  4475. SYMBOLIC PROCEDURE POLY!-MINUSP A;
  4476. IF A=NIL THEN NIL
  4477. ELSE IF DOMAINP A THEN MINUSP A
  4478. ELSE POLY!-MINUSP LC A;
  4479. SYMBOLIC PROCEDURE POLY!-ABS A;
  4480. IF POLY!-MINUSP A THEN NEGF A
  4481. ELSE A;
  4482. SYMBOLIC PROCEDURE FAC!-PRINTFACTORS L;
  4483. % procedure to print the result of factorize!-form;
  4484. % ie. l is of the form: (c . f)
  4485. % where c is the numeric content (may be 1)
  4486. % and f is of the form: ( (f1 . e1) (f2 . e2) ... (fn . en) )
  4487. % where the fi's are s.f.s and ei's are numbers;
  4488. << TERPRI();
  4489. IF NOT (CAR L = 1) THEN FAC!-PRINTSF CAR L;
  4490. FOR EACH ITEM IN CDR L DO
  4491. FAC!-PRINTSF !*P2F MKSP(PREPF CAR ITEM,CDR ITEM) >>;
  4492. %---------------------------------------------------------------------;
  4493. % The following would normally live in section: FACPRIM
  4494. %---------------------------------------------------------------------;
  4495. SYMBOLIC PROCEDURE INVERT!.POLY(U,VAR);
  4496. % u is a non-trivial primitive square free multivariate polynomial.
  4497. % assuming var is the top-level variable in u, this effectively
  4498. % reverses the position of the coeffts: ie
  4499. % a(n)*var**n + a(n-1)*var**(n-1) + ... + a(0)
  4500. % becomes:
  4501. % a(0)*var**n + a(1)*var**(n-1) + ... + a(n) . ;
  4502. BEGIN SCALAR W,INVERT!-SIGN;
  4503. W:=INVERT!.POLY1(RED U,LDEG U,LC U,VAR);
  4504. IF POLY!-MINUSP LC W THEN <<
  4505. W:=NEGF W;
  4506. INVERT!-SIGN:=-1 >>
  4507. ELSE INVERT!-SIGN:=1;
  4508. RETURN INVERT!-SIGN . W
  4509. END;
  4510. SYMBOLIC PROCEDURE INVERT!.POLY1(U,D,V,VAR);
  4511. % d is the degree of the poly we wish to invert.
  4512. % assume d > ldeg u always, and that v is never nil;
  4513. IF (DOMAINP U) OR NOT (MVAR U=VAR) THEN
  4514. (VAR TO D) .* U .+ V
  4515. ELSE INVERT!.POLY1(RED U,D,(VAR TO (D-LDEG U)) .* (LC U) .+ V,VAR);
  4516. SYMBOLIC PROCEDURE TRAILING!.COEFFT(U,VAR);
  4517. % u is multivariate poly with var as the top-level variable. we find
  4518. % the trailing coefft - ie the constant wrt var in u;
  4519. IF DOMAINP U THEN U
  4520. ELSE IF MVAR U=VAR THEN TRAILING!.COEFFT(RED U,VAR)
  4521. ELSE U;
  4522. %---------------------------------------------------------------------;
  4523. % The following would normally live in section: FACTOR
  4524. %---------------------------------------------------------------------;
  4525. SYMBOLIC PROCEDURE SIMPFACTORIZE U;
  4526. % factorize the polynomial p, putting the factors into
  4527. % the array w, and return the number of factors found.
  4528. % w(0) gets set to the (numeric) content of p (which
  4529. % may well be just +1). w should be a one-dimensional array. if it
  4530. % the name of a variable, not an array, the variables w0, w1,...
  4531. % will be set instead;
  4532. BEGIN SCALAR P,W,!*FORCE!-PRIME,X,Y,Z,FACTOR!-COUNT;
  4533. IF ATOM U THEN REDERR "FACTORIZE needs arguments"
  4534. ELSE IF ATOM CDR U THEN U := LIST(CAR U,'FACTOR);
  4535. P:= !*Q2F SIMP!* CAR U;
  4536. W := CADR U;
  4537. IF NOT ATOM CDDR U AND NUMBERP CADDR U THEN
  4538. !*FORCE!-PRIME := CADDR U;
  4539. X:=FACTORF1(P,!*FORCE!-PRIME);
  4540. Z:= (0 . CAR X) . NIL;
  4541. FACTOR!-COUNT:=0;
  4542. FOR EACH FFF IN CDR X DO
  4543. FOR I:=1:CDR FFF DO
  4544. Z:=((FACTOR!-COUNT:=FACTOR!-COUNT+1) .
  4545. MK!*SQ(CAR FFF ./ 1)) . Z;
  4546. RETURN MULTIPLE!-RESULT(Z,W)
  4547. END;
  4548. PUT('FACTORIZE,'SIMPFN,'SIMPFACTORIZE);
  4549. %---------------------------------------------------------------------;
  4550. % The following would normally live in section: IMAGESET
  4551. %---------------------------------------------------------------------;
  4552. SYMBOLIC PROCEDURE MAKE!-IMAGE!-LC!-LIST(U,IMSET);
  4553. REVERSEWOC MAKE!-IMAGE!-LC!-LIST1(U,IMSET,
  4554. FOR EACH X IN IMSET COLLECT CAR X);
  4555. SYMBOLIC PROCEDURE MAKE!-IMAGE!-LC!-LIST1(U,IMSET,VARLIST);
  4556. % If IMSET=((x1 . a1, x2 . a2, ... , xn . an)) (ordered) where xj is
  4557. % the variable and aj its value, then this fn creates n images of U wrt
  4558. % sets S(i) where S(i)= ((x1 . a1), ... , (xi . ai)). The result is an
  4559. % ordered list of pairs: (u(i) . X(i+1)) where u(i)= U wrt S(i) and
  4560. % X(i) = (xi, ... , xn) and X(n+1) = NIL. VARLIST = X(1).
  4561. % (Note. the variables tagged to u(i) should be all those
  4562. % appearing in u(i) unless it is degenerate). The returned list is
  4563. % ordered with u(1) first and ending with the number u(n);
  4564. IF NULL IMSET THEN NIL
  4565. ELSE IF DOMAINP U THEN LIST(!*D2N U . CDR VARLIST)
  4566. ELSE IF MVAR U=CAAR IMSET THEN
  4567. BEGIN SCALAR W;
  4568. W:=HORNER!-RULE!-FOR!-ONE!-VAR(
  4569. U,CAAR IMSET,CDAR IMSET,POLYZERO,LDEG U) . CDR VARLIST;
  4570. RETURN
  4571. IF POLYZEROP CAR W THEN LIST (0 . CDR W)
  4572. ELSE (W . MAKE!-IMAGE!-LC!-LIST1(CAR W,CDR IMSET,CDR VARLIST))
  4573. END
  4574. ELSE MAKE!-IMAGE!-LC!-LIST1(U,CDR IMSET,CDR VARLIST);
  4575. SYMBOLIC PROCEDURE HORNER!-RULE!-FOR!-ONE!-VAR(U,X,VAL,C,DEGG);
  4576. IF DOMAINP U OR NOT(MVAR U=X) THEN ADDF(U,MULTF(C,!*NUM2F(VAL**DEGG)))
  4577. ELSE BEGIN SCALAR NEWDEG;
  4578. NEWDEG:=LDEG U;
  4579. RETURN HORNER!-RULE!-FOR!-ONE!-VAR(RED U,X,VAL,
  4580. ADDF(LC U,MULTF(C,!*NUM2F(VAL**(IDIFFERENCE(DEGG,NEWDEG))))),
  4581. NEWDEG)
  4582. END;
  4583. SYMBOLIC PROCEDURE MAKE!-IMAGE(U,IMSET);
  4584. % finds image of u wrt image set, imset, (=association list);
  4585. IF DOMAINP U THEN U
  4586. ELSE IF MVAR U=M!-IMAGE!-VARIABLE THEN
  4587. ADJOIN!-TERM(LPOW U,!*NUM2F EVALUATE!-IN!-ORDER(LC U,IMSET),
  4588. MAKE!-IMAGE(RED U,IMSET))
  4589. ELSE !*NUM2F EVALUATE!-IN!-ORDER(U,IMSET);
  4590. SYMBOLIC PROCEDURE EVALUATE!-IN!-ORDER(U,IMSET);
  4591. % makes an image of u wrt imageset, imset, using horner's rule. result
  4592. % should be purely numeric;
  4593. IF DOMAINP U THEN !*D2N U
  4594. ELSE IF MVAR U=CAAR IMSET THEN
  4595. HORNER!-RULE(EVALUATE!-IN!-ORDER(LC U,CDR IMSET),
  4596. LDEG U,RED U,IMSET)
  4597. ELSE EVALUATE!-IN!-ORDER(U,CDR IMSET);
  4598. SYMBOLIC PROCEDURE HORNER!-RULE(C,DEGG,A,VSET);
  4599. % c is running total and a is what is left;
  4600. IF DOMAINP A THEN (!*D2N A)+C*((CDAR VSET)**DEGG)
  4601. ELSE IF NOT(MVAR A=CAAR VSET) THEN
  4602. EVALUATE!-IN!-ORDER(A,CDR VSET)+C*((CDAR VSET)**DEGG)
  4603. ELSE BEGIN SCALAR NEWDEG;
  4604. NEWDEG:=LDEG A;
  4605. RETURN HORNER!-RULE(EVALUATE!-IN!-ORDER(LC A,CDR VSET)
  4606. +C*((CDAR VSET)**(IDIFFERENCE(DEGG,NEWDEG))),NEWDEG,RED A,VSET)
  4607. END;
  4608. %---------------------------------------------------------------------;
  4609. % The following would normally live in section: MHENSFNS
  4610. %---------------------------------------------------------------------;
  4611. SYMBOLIC PROCEDURE MAX!-DEGREE(U,N);
  4612. % finds maximum degree of any single variable in U (n is max so far);
  4613. IF DOMAINP U THEN N
  4614. ELSE IF IGREATERP(N,LDEG U) THEN
  4615. MAX!-DEGREE(RED U,MAX!-DEGREE(LC U,N))
  4616. ELSE MAX!-DEGREE(RED U,MAX!-DEGREE(LC U,LDEG U));
  4617. SYMBOLIC PROCEDURE DIFF!-OVER!-K!-MOD!-P(U,K,V);
  4618. % derivative of u wrt v divided by k (=number);
  4619. IF DOMAINP U THEN NIL
  4620. ELSE IF MVAR U = V THEN
  4621. IF LDEG U = 1 THEN QUOTIENT!-MOD!-P(LC U,MODULAR!-NUMBER K)
  4622. ELSE ADJOIN!-TERM(MKSP(V,ISUB1 LDEG U),
  4623. QUOTIENT!-MOD!-P(
  4624. TIMES!-MOD!-P(MODULAR!-NUMBER LDEG U,LC U),
  4625. MODULAR!-NUMBER K),
  4626. DIFF!-OVER!-K!-MOD!-P(RED U,K,V))
  4627. ELSE ADJOIN!-TERM(LPOW U,
  4628. DIFF!-OVER!-K!-MOD!-P(LC U,K,V),
  4629. DIFF!-OVER!-K!-MOD!-P(RED U,K,V));
  4630. SYMBOLIC PROCEDURE DIFF!-K!-TIMES!-MOD!-P(U,K,V);
  4631. % differentiates u k times wrt v and divides by (k!) ie. for each term
  4632. % a*v**n we get [n k]*a*v**(n-k) if n>=k and nil if n<k where
  4633. % [n k] is the binomial coefficient;
  4634. IF DOMAINP U THEN NIL
  4635. ELSE IF MVAR U = V THEN
  4636. IF LDEG U < K THEN NIL
  4637. ELSE IF LDEG U = K THEN LC U
  4638. ELSE ADJOIN!-TERM(MKSP(V,LDEG U - K),
  4639. TIMES!-MOD!-P(BINOMIAL!-COEFFT!-MOD!-P(LDEG U,K),LC U),
  4640. DIFF!-K!-TIMES!-MOD!-P(RED U,K,V))
  4641. ELSE ADJOIN!-TERM(LPOW U,
  4642. DIFF!-K!-TIMES!-MOD!-P(LC U,K,V),
  4643. DIFF!-K!-TIMES!-MOD!-P(RED U,K,V));
  4644. SYMBOLIC PROCEDURE SPREADVAR(U,V,SLIST);
  4645. % find all the powers of V in U and merge their degrees into SLIST.
  4646. % We ignore the constant term wrt V;
  4647. IF DOMAINP U THEN SLIST
  4648. ELSE <<
  4649. IF MVAR U=V AND NOT MEMBER(LDEG U,SLIST) THEN SLIST:=LDEG U . SLIST;
  4650. SPREADVAR(RED U,V,SPREADVAR(LC U,V,SLIST)) >>;
  4651. %---------------------------------------------------------------------;
  4652. % The following would normally live in section: UNIHENS
  4653. %---------------------------------------------------------------------;
  4654. SYMBOLIC PROCEDURE ROOT!-SQUARES(U,SOFAR);
  4655. IF NULL U THEN PMAM!-SQRT SOFAR
  4656. ELSE IF DOMAINP U THEN PMAM!-SQRT(SOFAR+(U*U))
  4657. ELSE ROOT!-SQUARES(RED U,SOFAR+(LC U * LC U));
  4658. %---------------------------------------------------------------------;
  4659. % The following would normally live in section: VECPOLY
  4660. %---------------------------------------------------------------------;
  4661. SYMBOLIC PROCEDURE POLY!-TO!-VECTOR P;
  4662. % spread the given univariate polynomial out into POLY-VECTOR;
  4663. IF ISDOMAIN P THEN PUTV(POLY!-VECTOR,0,!*D2N P)
  4664. ELSE <<
  4665. PUTV(POLY!-VECTOR,LDEG P,LC P);
  4666. POLY!-TO!-VECTOR RED P >>;
  4667. SYMBOLIC PROCEDURE VECTOR!-TO!-POLY(P,D,V);
  4668. % Convert the vector P into a polynomial of degree D in variable V;
  4669. BEGIN
  4670. SCALAR R;
  4671. IF D#<0 THEN RETURN NIL;
  4672. R:=!*N2F GETV(P,0);
  4673. FOR I:=1:D DO
  4674. IF GETV(P,I) NEQ 0 THEN R:=((V TO I) .* GETV(P,I)) .+ R;
  4675. RETURN R
  4676. END;
  4677. ENDMODULE;
  4678. MODULE LINMODP;
  4679. % *******************************************************************
  4680. %
  4681. % copyright (c) university of cambridge, england 1979
  4682. %
  4683. % *******************************************************************;
  4684. %**********************************************************************;
  4685. %
  4686. % This section solves linear equations mod p;
  4687. SYMBOLIC PROCEDURE LU!-FACTORIZE!-MOD!-P(A,N);
  4688. % A is a matrix of size N*N. Overwrite it with its LU factorization;
  4689. BEGIN SCALAR W;
  4690. FOR I:=1:N DO BEGIN
  4691. SCALAR II,PIVOT;
  4692. II:=I;
  4693. WHILE (PIVOT:=GETM2(A,II,I))=0
  4694. OR IREMAINDER(PIVOT,PRIME!-BASE)=0 DO <<
  4695. II:=II+1;
  4696. IF II>N THEN RETURN W:='SINGULAR >>;
  4697. IF W='SINGULAR THEN RETURN W;
  4698. IF NOT II=I THEN BEGIN
  4699. SCALAR TEMP;
  4700. TEMP:=GETV(A,I);
  4701. PUTV(A,I,GETV(A,II));
  4702. PUTV(A,II,TEMP) END;
  4703. PUTM2(A,I,0,II); % Remember pivoting information;
  4704. PIVOT:=MODULAR!-RECIPROCAL PIVOT;
  4705. PUTM2(A,I,I,PIVOT);
  4706. FOR J:=I+1:N DO
  4707. PUTM2(A,I,J,MODULAR!-TIMES(PIVOT,GETM2(A,I,J)));
  4708. FOR II:=I+1:N DO BEGIN
  4709. SCALAR MULTIPLE;
  4710. MULTIPLE:=GETM2(A,II,I);
  4711. FOR J:=I+1:N DO
  4712. PUTM2(A,II,J,MODULAR!-DIFFERENCE(GETM2(A,II,J),
  4713. MODULAR!-TIMES(MULTIPLE,GETM2(A,I,J)))) END END;
  4714. RETURN W
  4715. END;
  4716. SYMBOLIC PROCEDURE BACK!-SUBSTITUTE(A,V,N);
  4717. % A is an N*N matrix as produced by LU-FACTORIZE-MOD-P, and V is
  4718. % a vector of length N. Overwrite V with solution to linear equations;
  4719. BEGIN
  4720. FOR I:=1:N DO BEGIN
  4721. SCALAR II;
  4722. II:=GETM2(A,I,0); % Pivot control;
  4723. IF NOT II=I THEN DO BEGIN
  4724. SCALAR TEMP;
  4725. TEMP:=GETV(V,I); PUTV(V,I,GETV(V,II)); PUTV(V,II,TEMP) END
  4726. END;
  4727. FOR I:=1:N DO BEGIN
  4728. PUTV(V,I,TIMES!-MOD!-P(!*N2F GETM2(A,I,I),GETV(V,I)));
  4729. FOR II:=I+1:N DO
  4730. PUTV(V,II,DIFFERENCE!-MOD!-P(GETV(V,II),
  4731. TIMES!-MOD!-P(GETV(V,I),!*N2F GETM2(A,II,I)))) END;
  4732. % Now do the actual back substitution;
  4733. FOR I:=N-1 STEP -1 UNTIL 1 DO
  4734. FOR J:=I+1:N DO
  4735. PUTV(V,I,DIFFERENCE!-MOD!-P(GETV(V,I),
  4736. TIMES!-MOD!-P(!*N2F GETM2(A,I,J),GETV(V,J))));
  4737. RETURN V
  4738. END;
  4739. ENDMODULE;
  4740. MODULE MHENSFNS;
  4741. % *******************************************************************
  4742. %
  4743. % copyright (c) university of cambridge, england 1979
  4744. %
  4745. % *******************************************************************;
  4746. %**********************************************************************;
  4747. % This section contains some of the functions used in
  4748. % the multivariate hensel growth. (ie they are called from
  4749. % section MULTIHEN or function RECONSTRUCT-MULTIVARIATE-FACTORS). ;
  4750. SYMBOLIC PROCEDURE SET!-DEGREE!-BOUNDS V;
  4751. DEGREE!-BOUNDS:=FOR EACH VAR IN V COLLECT
  4752. (CAR VAR . DEGREE!-IN!-VARIABLE(MULTIVARIATE!-INPUT!-POLY,CAR VAR));
  4753. SYMBOLIC PROCEDURE GET!-DEGREE!-BOUND V;
  4754. BEGIN SCALAR W;
  4755. W:=ATSOC(V,DEGREE!-BOUNDS);
  4756. IF NULL W THEN ERRORF(LIST("Degree bound not found for ",
  4757. V," in ",DEGREE!-BOUNDS));
  4758. RETURN CDR W
  4759. END;
  4760. SYMBOLIC PROCEDURE CHOOSE!-LARGER!-PRIME N;
  4761. % our prime base in the multivariate hensel must be greater than n so
  4762. % this sets a new prime to be that (previous one was found to be no
  4763. % good). We also set up various fluids e.g. the Alphas;
  4764. % the primes we can choose are < 2**24 so if n is bigger
  4765. % we collapse;
  4766. IF N > 2**24-1 THEN
  4767. ERRORF LIST("CANNOT CHOOSE PRIME > GIVEN NUMBER:",N)
  4768. ELSE BEGIN SCALAR P,FLIST!-MOD!-P,K,FVEC!-MOD!-P,FORBIDDEN!-PRIMES;
  4769. TRYNEWPRIME:
  4770. IF P THEN FORBIDDEN!-PRIMES:=P . FORBIDDEN!-PRIMES;
  4771. P:=RANDOM!-PRIME();
  4772. % this chooses a word-size prime (currently 24 bits);
  4773. SET!-MODULUS P;
  4774. IF NOT(P>N) OR MEMBER(P,FORBIDDEN!-PRIMES) OR
  4775. POLYZEROP REDUCE!-MOD!-P LC MULTIVARIATE!-INPUT!-POLY THEN
  4776. GOTO TRYNEWPRIME;
  4777. FOR I:=1:NUMBER!-OF!-FACTORS DO
  4778. FLIST!-MOD!-P:=(REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I) .
  4779. FLIST!-MOD!-P);
  4780. ALPHALIST:=ALPHAS(NUMBER!-OF!-FACTORS,FLIST!-MOD!-P,1);
  4781. IF ALPHALIST='FACTORS! NOT! COPRIME THEN GOTO TRYNEWPRIME;
  4782. HENSEL!-GROWTH!-SIZE:=P;
  4783. PRIME!-BASE:=P;
  4784. FACTOR!-TRACE <<
  4785. PRIN2!* "New prime chosen: ";
  4786. PRINTSTR HENSEL!-GROWTH!-SIZE >>;
  4787. K:=NUMBER!-OF!-FACTORS;
  4788. FVEC!-MOD!-P:=MKVECT K;
  4789. FOR EACH W IN FLIST!-MOD!-P DO <<
  4790. PUTV(FVEC!-MOD!-P,K,W); K:=ISUB1 K >>;
  4791. RETURN FVEC!-MOD!-P
  4792. END;
  4793. SYMBOLIC PROCEDURE BINOMIAL!-COEFFT!-MOD!-P(N,R);
  4794. IF N<R THEN NIL
  4795. ELSE IF N=R THEN 1
  4796. ELSE IF R=1 THEN !*NUM2F MODULAR!-NUMBER N
  4797. ELSE BEGIN SCALAR N!-C!-R,B,J;
  4798. N!-C!-R:=1;
  4799. B:=MIN(R,N-R);
  4800. N:=MODULAR!-NUMBER N;
  4801. R:=MODULAR!-NUMBER R;
  4802. FOR I:=1:B DO <<
  4803. J:=MODULAR!-NUMBER I;
  4804. N!-C!-R:=MODULAR!-QUOTIENT(
  4805. MODULAR!-TIMES(N!-C!-R,
  4806. MODULAR!-DIFFERENCE(N,MODULAR!-DIFFERENCE(J,1))),
  4807. J) >>;
  4808. RETURN !*NUM2F N!-C!-R
  4809. END;
  4810. SYMBOLIC PROCEDURE MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(BVEC,N);
  4811. % makes a vector whose ith elt is product over j [ BVEC(j) ] / BVEC(i);
  4812. % NB. we must NOT actually do the division here as we are likely
  4813. % to be working mod p**n (some n > 1) and the division can involve
  4814. % a division by p.;
  4815. BEGIN SCALAR BHATVEC,R;
  4816. BHATVEC:=MKVECT N;
  4817. FOR I:=1:N DO <<
  4818. R:=1;
  4819. FOR J:=1:N DO IF NOT(J=I) THEN R:=TIMES!-MOD!-P(R,GETV(BVEC,J));
  4820. PUTV(BHATVEC,I,R) >>;
  4821. RETURN BHATVEC
  4822. END;
  4823. SYMBOLIC PROCEDURE MAX!-DEGREE!-IN!-VAR(FVEC,V);
  4824. BEGIN SCALAR R,D;
  4825. R:=0;
  4826. FOR I:=1:NUMBER!-OF!-FACTORS DO
  4827. IF R<(D:=DEGREE!-IN!-VARIABLE(GETV(FVEC,I),V)) THEN R:=D;
  4828. RETURN R
  4829. END;
  4830. SYMBOLIC PROCEDURE MAKE!-GROWTH!-FACTOR PT;
  4831. % pt is of form (v . n) where v is a variable. we make the s.f. v-n;
  4832. IF CDR PT=0 THEN !*F2MOD !*K2F CAR PT
  4833. ELSE PLUS!-MOD!-P(!*F2MOD !*K2F CAR PT,MODULAR!-MINUS CDR PT);
  4834. SYMBOLIC PROCEDURE TERMS!-DONE!-MOD!-P(FVEC,DELFVEC,DELFACTOR);
  4835. % calculate the terms introduced by the corrections in DELFVEC;
  4836. BEGIN SCALAR FLIST,DELFLIST;
  4837. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  4838. FLIST:=GETV(FVEC,I) . FLIST;
  4839. DELFLIST:=GETV(DELFVEC,I) . DELFLIST >>;
  4840. RETURN TERMS!-DONE1!-MOD!-P(NUMBER!-OF!-FACTORS,FLIST,DELFLIST,
  4841. NUMBER!-OF!-FACTORS,DELFACTOR)
  4842. END;
  4843. SYMBOLIC PROCEDURE TERMS!-DONE1!-MOD!-P(N,FLIST,DELFLIST,R,M);
  4844. IF N=1 THEN (CAR FLIST) . (CAR DELFLIST)
  4845. ELSE BEGIN SCALAR K,I,F1,F2,DELF1,DELF2;
  4846. K:=N/2; I:=1;
  4847. FOR EACH F IN FLIST DO
  4848. << IF I>K THEN F2:=(F . F2)
  4849. ELSE F1:=(F . F1);
  4850. I:=I+1 >>;
  4851. I:=1;
  4852. FOR EACH DELF IN DELFLIST DO
  4853. << IF I>K THEN DELF2:=(DELF . DELF2)
  4854. ELSE DELF1:=(DELF . DELF1);
  4855. I:=I+1 >>;
  4856. F1:=TERMS!-DONE1!-MOD!-P(K,F1,DELF1,R,M);
  4857. DELF1:=CDR F1; F1:=CAR F1;
  4858. F2:=TERMS!-DONE1!-MOD!-P(N-K,F2,DELF2,R,M);
  4859. DELF2:=CDR F2; F2:=CAR F2;
  4860. DELF1:=
  4861. PLUS!-MOD!-P(PLUS!-MOD!-P(
  4862. TIMES!-MOD!-P(F1,DELF2),
  4863. TIMES!-MOD!-P(F2,DELF1)),
  4864. TIMES!-MOD!-P(TIMES!-MOD!-P(DELF1,M),DELF2));
  4865. IF N=R THEN RETURN DELF1;
  4866. RETURN (TIMES!-MOD!-P(F1,F2) . DELF1)
  4867. END;
  4868. SYMBOLIC PROCEDURE PRIMITIVE!.PARTS(FLIST,VAR,UNIVARIATE!-INPUTS);
  4869. % finds the prim.part of each factor in flist wrt variable var;
  4870. % Note that FLIST may contain univariate or multivariate S.F.s
  4871. % (according to UNIVARIATE!-INPUTS) - in the former case we correct the
  4872. % ALPHALIST if necessary;
  4873. BEGIN SCALAR C,PRIMF;
  4874. IF NULL VAR THEN
  4875. ERRORF "Must take primitive parts wrt some non-null variable";
  4876. IF NON!-MONIC THEN
  4877. FACTOR!-TRACE <<
  4878. PRINTSTR "Because we multiplied the original primitive";
  4879. PRINTSTR "polynomial by a multiple of its leading coefficient";
  4880. PRINTSTR "(see (a) above), the factors we have now are not";
  4881. PRINTSTR "necessarily primitive. However the required factors";
  4882. PRINTSTR "are merely their primitive parts." >>;
  4883. RETURN FOR EACH FW IN FLIST COLLECT
  4884. << IF NOT DEPENDS!-ON!-VAR(FW,VAR) THEN
  4885. ERRORF LIST("WRONG VARIABLE",VAR,FW);
  4886. C:=COMFAC FW;
  4887. IF CAR C THEN ERRORF(LIST(
  4888. "FACTOR DIVISIBLE BY MAIN VARIABLE:",FW,CAR C));
  4889. PRIMF:=QUOTFAIL(FW,CDR C);
  4890. IF NOT(CDR C=1) AND UNIVARIATE!-INPUTS THEN
  4891. MULTIPLY!-ALPHAS(CDR C,FW,PRIMF);
  4892. PRIMF >>
  4893. END;
  4894. SYMBOLIC PROCEDURE MAKE!-PREDICTED!-FORMS(PFS,V);
  4895. % PFS is a vector of S.F.s which represents the sparsity of
  4896. % the associated polynomials wrt V. Here PFS is adjusted to a
  4897. % suitable form for handling this sparsity. ie. we record the
  4898. % degrees of V in a vector for each poly in PFS. Each
  4899. % monomial (in V) represents an unknown (its coefft) in the predicted
  4900. % form of the associated poly. We count the maximum no of unknowns for
  4901. % each poly and return the maximum of these;
  4902. BEGIN SCALAR L,N,PVEC,J,W;
  4903. MAX!-UNKNOWNS:=0;
  4904. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  4905. W:=GETV(PFS,I); % get the ith poly;
  4906. L:=SORT(SPREADVAR(W,V,NIL),FUNCTION LESSP);
  4907. % Pick out the monomials in V from this poly and order
  4908. % them in increasing degree;
  4909. N:=IADD1 LENGTH L; % no of unknowns in predicted poly - we add
  4910. % one for the constant term;
  4911. NUMBER!-OF!-UNKNOWNS:=(N . I) . NUMBER!-OF!-UNKNOWNS;
  4912. IF MAX!-UNKNOWNS<N THEN MAX!-UNKNOWNS:=N;
  4913. PVEC:=MKVECT ISUB1 N;
  4914. % get space for the info on this poly;
  4915. J:=0;
  4916. PUTV(PVEC,J,ISUB1 N);
  4917. % put in the length of this vector which will vary
  4918. % from poly to poly;
  4919. FOR EACH M IN L DO PUTV(PVEC,J:=IADD1 J,M);
  4920. % put in the monomial info;
  4921. PUTV(PFS,I,PVEC);
  4922. % overwrite the S.F. in PFS with the more compact vector;
  4923. >>;
  4924. NUMBER!-OF!-UNKNOWNS:=SORT(NUMBER!-OF!-UNKNOWNS,FUNCTION LESSPCAR);
  4925. RETURN MAX!-UNKNOWNS
  4926. END;
  4927. SYMBOLIC PROCEDURE MAKE!-CORRECTION!-VECTORS(PFS,BFS,N);
  4928. % set up space for the vector of vectors to hold the correction
  4929. % terms as we generate them by the function SOLVE-FOR-CORRECTIONS.
  4930. % Also put in the starting values;
  4931. BEGIN SCALAR CVS,CV;
  4932. CVS:=MKVECT NUMBER!-OF!-FACTORS;
  4933. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  4934. CV:=MKVECT N;
  4935. % each CV will hold the corrections for the ith factor;
  4936. % the no of corrections we put in here depends on the
  4937. % maximum no of unknowns we have in the predicted
  4938. % forms, giving a set of soluble linear systems (hopefully);
  4939. PUTV(CV,1,GETV(BFS,I));
  4940. % put in the first 'corrections';
  4941. PUTV(CVS,I,CV) >>;
  4942. RETURN CVS
  4943. END;
  4944. SYMBOLIC PROCEDURE CONSTRUCT!-SOLN!-MATRICES(PFS,VAL);
  4945. % Here we construct the matrices - one for each linear system
  4946. % we will have to solve to see if our predicted forms of the
  4947. % answer are correct. Each matrix is a vector of row-vectors
  4948. % - the ijth elt is in jth slot of ith row-vector (ie zero slots
  4949. % are not used here);
  4950. BEGIN SCALAR SOLN!-MATRIX,RESVEC,N,PV;
  4951. RESVEC:=MKVECT NUMBER!-OF!-FACTORS;
  4952. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  4953. PV:=GETV(PFS,I);
  4954. SOLN!-MATRIX:=MKVECT(N:=IADD1 GETV(PV,0));
  4955. CONSTRUCT!-ITH!-MATRIX(SOLN!-MATRIX,PV,N,VAL);
  4956. PUTV(RESVEC,I,SOLN!-MATRIX) >>;
  4957. RETURN RESVEC
  4958. END;
  4959. SYMBOLIC PROCEDURE CONSTRUCT!-ITH!-MATRIX(SM,PV,N,VAL);
  4960. BEGIN SCALAR MV;
  4961. MV:=MKVECT N; % this will be the first row;
  4962. PUTV(MV,1,1); % the first column represents the constant term;
  4963. FOR J:=2:N DO PUTV(MV,J,MODULAR!-EXPT(VAL,GETV(PV,ISUB1 J)));
  4964. % first row is straight substitution;
  4965. PUTV(SM,1,MV);
  4966. % now for the rest of the rows: ;
  4967. FOR J:=2:N DO <<
  4968. MV:=MKVECT N;
  4969. PUTV(MV,1,0);
  4970. CONSTRUCT!-MATRIX!-ROW(MV,ISUB1 J,PV,N,VAL);
  4971. PUTV(SM,J,MV) >>
  4972. END;
  4973. SYMBOLIC PROCEDURE CONSTRUCT!-MATRIX!-ROW(MROW,J,PV,N,VAL);
  4974. BEGIN SCALAR D;
  4975. FOR K:=2:N DO <<
  4976. D:=GETV(PV,ISUB1 K); % degree representing the monomial;
  4977. IF D<J THEN PUTV(MROW,K,0)
  4978. ELSE <<
  4979. D:=MODULAR!-TIMES(!*D2N BINOMIAL!-COEFFT!-MOD!-P(D,J),
  4980. MODULAR!-EXPT(VAL,IDIFFERENCE(D,J)));
  4981. % differentiate and substitute all at once;
  4982. PUTV(MROW,K,D) >> >>
  4983. END;
  4984. SYMBOLIC PROCEDURE PRINT!-LINEAR!-SYSTEMS(SOLN!-M,CORRECTION!-V,
  4985. PREDICTED!-F,V);
  4986. <<
  4987. FOR I:=1:NUMBER!-OF!-FACTORS DO
  4988. PRINT!-LINEAR!-SYSTEM(I,SOLN!-M,CORRECTION!-V,PREDICTED!-F,V);
  4989. TERPRI!*(NIL) >>;
  4990. SYMBOLIC PROCEDURE PRINT!-LINEAR!-SYSTEM(I,SOLN!-M,CORRECTION!-V,
  4991. PREDICTED!-F,V);
  4992. BEGIN SCALAR PV,SM,CV,MR,N,TT;
  4993. TERPRI!*(T);
  4994. PRIN2!* " i = "; PRINTSTR I;
  4995. TERPRI!*(NIL);
  4996. SM:=GETV(SOLN!-M,I);
  4997. CV:=GETV(CORRECTION!-V,I);
  4998. PV:=GETV(PREDICTED!-F,I);
  4999. N:=IADD1 GETV(PV,0);
  5000. FOR J:=1:N DO << % for each row in matrix ... ;
  5001. PRIN2!* "( ";
  5002. TT:=2;
  5003. MR:=GETV(SM,J); % matrix row;
  5004. FOR K:=1:N DO << % for each elt in row ... ;
  5005. PRIN2!* GETV(MR,K);
  5006. TTAB!* (TT:=TT+10) >>;
  5007. PRIN2!* ") ( [";
  5008. IF J=1 THEN PRIN2!* 1
  5009. ELSE PRINSF ADJOIN!-TERM(MKSP(V,GETV(PV,ISUB1 J)),1,POLYZERO);
  5010. PRIN2!* "]";
  5011. TTAB!* (TT:=TT+10);
  5012. PRIN2!* " )";
  5013. IF J=(N/2) THEN PRIN2!* " = ( " ELSE PRIN2!* " ( ";
  5014. PRINSF GETV(CV,J);
  5015. TTAB!* (TT:=TT+30); PRINTSTR ")";
  5016. IF NOT(J=N) THEN <<
  5017. TT:=2;
  5018. PRIN2!* "(";
  5019. TTAB!* (TT:=TT+N*10);
  5020. PRIN2!* ") (";
  5021. TTAB!* (TT:=TT+10);
  5022. PRIN2!* " ) (";
  5023. TTAB!* (TT:=TT+30);
  5024. PRINTSTR ")" >> >>;
  5025. TERPRI!*(T)
  5026. END;
  5027. SYMBOLIC PROCEDURE TRY!-PREDICTION(SM,CV,PV,N,I,POLY,V,FF,FFHAT,
  5028. LU!-DECOMPN!-DONE);
  5029. BEGIN SCALAR W,FFI,FHATI;
  5030. SM:=GETV(SM,I);
  5031. CV:=GETV(CV,I);
  5032. PV:=GETV(PV,I);
  5033. IF NOT(N=IADD1 GETV(PV,0)) THEN
  5034. ERRORF LIST("Predicted unknowns gone wrong? ",N,IADD1 GETV(PV,0));
  5035. IF NOT LU!-DECOMPN!-DONE THEN <<
  5036. W:=LU!-FACTORIZE!-MOD!-P(SM,N);
  5037. IF W='SINGULAR THEN <<
  5038. FACTOR!-TRACE <<
  5039. PRIN2!* "Prediction for ";
  5040. PRIN2!* IF NULL FF THEN 'f ELSE 'a;
  5041. PRIN2!* "("; PRIN2!* I;
  5042. PRINTSTR ") failed due to singular matrix." >>;
  5043. RETURN (W . I) >> >>;
  5044. BACK!-SUBSTITUTE(SM,CV,N);
  5045. W:=
  5046. IF NULL FF THEN TRY!-FACTOR(POLY,CV,PV,N,V)
  5047. ELSE <<
  5048. FFI := GETV(FF,I);
  5049. FHATI := GETV(FFHAT,I); % The unfolding here is to get round
  5050. % a bug in the PSL compiler 12/9/82. It
  5051. % will be tidied back up as soon as
  5052. % possible;
  5053. TRY!-ALPHA(POLY,CV,PV,N,V,FFI,FHATI) >>;
  5054. IF W='BAD!-PREDICTION THEN <<
  5055. FACTOR!-TRACE <<
  5056. PRIN2!* "Prediction for ";
  5057. PRIN2!* IF NULL FF THEN 'f ELSE 'a;
  5058. PRIN2!* "("; PRIN2!* I;
  5059. PRINTSTR ") was an inadequate guess." >>;
  5060. RETURN (W . I) >>;
  5061. FACTOR!-TRACE <<
  5062. PRIN2!* "Prediction for ";
  5063. PRIN2!* IF NULL FF THEN 'f ELSE 'a;
  5064. PRIN2!* "("; PRIN2!* I; PRIN2!* ") worked: ";
  5065. FAC!-PRINTSF CAR W >>;
  5066. RETURN (I . W)
  5067. END;
  5068. SYMBOLIC PROCEDURE TRY!-FACTOR(POLY,TESTV,PREDICTEDF,N,V);
  5069. BEGIN SCALAR R,W;
  5070. R:=GETV(TESTV,1);
  5071. FOR J:=2:N DO <<
  5072. W:=!*F2MOD ADJOIN!-TERM(MKSP(V,GETV(PREDICTEDF,ISUB1 J)),1,
  5073. POLYZERO);
  5074. R:=PLUS!-MOD!-P(R,TIMES!-MOD!-P(W,GETV(TESTV,J))) >>;
  5075. W:=QUOTIENT!-MOD!-P(POLY,R);
  5076. IF DIDNTGO W OR
  5077. NOT POLYZEROP DIFFERENCE!-MOD!-P(POLY,TIMES!-MOD!-P(W,R)) THEN
  5078. RETURN 'BAD!-PREDICTION
  5079. ELSE RETURN LIST(R,W)
  5080. END;
  5081. SYMBOLIC PROCEDURE TRY!-ALPHA(POLY,TESTV,PREDICTEDF,N,V,FI,FHATI);
  5082. BEGIN SCALAR R,W,WR;
  5083. R:=GETV(TESTV,1);
  5084. FOR J:=2:N DO <<
  5085. W:=!*F2MOD ADJOIN!-TERM(MKSP(V,GETV(PREDICTEDF,ISUB1 J)),1,
  5086. POLYZERO);
  5087. R:=PLUS!-MOD!-P(R,TIMES!-MOD!-P(W,GETV(TESTV,J))) >>;
  5088. IF POLYZEROP
  5089. (WR:=DIFFERENCE!-MOD!-P(POLY,TIMES!-MOD!-P(R,FHATI))) THEN
  5090. RETURN LIST (R,WR);
  5091. W:=QUOTIENT!-MOD!-P(WR,FI);
  5092. IF DIDNTGO W OR
  5093. NOT POLYZEROP DIFFERENCE!-MOD!-P(WR,TIMES!-MOD!-P(W,FI)) THEN
  5094. RETURN 'BAD!-PREDICTION
  5095. ELSE RETURN LIST(R,WR)
  5096. END;
  5097. ENDMODULE;
  5098. MODULE MODPOLY;
  5099. % *******************************************************************
  5100. %
  5101. % copyright (c) university of cambridge, england 1979
  5102. %
  5103. % *******************************************************************;
  5104. %**********************************************************************;
  5105. % routines for performing arithmetic on multivariate
  5106. % polynomials with coefficients that are modular
  5107. % numbers as defined by modular!-plus etc;
  5108. % note that the datastructure used is the same as that used in
  5109. % REDUCE except that it is assumesd that domain elements are atomic;
  5110. SYMBOLIC PROCEDURE PLUS!-MOD!-P(A,B);
  5111. % form the sum of the two polynomials a and b
  5112. % working over the ground domain defined by the routines
  5113. % modular!-plus, modular!-times etc. the inputs to this
  5114. % routine are assumed to have coefficients already
  5115. % in the required domain;
  5116. IF NULL A THEN B
  5117. ELSE IF NULL B THEN A
  5118. ELSE IF ISDOMAIN A THEN
  5119. IF ISDOMAIN B THEN !*NUM2F MODULAR!-PLUS(A,B)
  5120. ELSE (LT B) .+ PLUS!-MOD!-P(A,RED B)
  5121. ELSE IF ISDOMAIN B THEN (LT A) .+ PLUS!-MOD!-P(RED A,B)
  5122. ELSE IF LPOW A = LPOW B THEN
  5123. ADJOIN!-TERM(LPOW A,
  5124. PLUS!-MOD!-P(LC A,LC B),PLUS!-MOD!-P(RED A,RED B))
  5125. ELSE IF COMES!-BEFORE(LPOW A,LPOW B) THEN
  5126. (LT A) .+ PLUS!-MOD!-P(RED A,B)
  5127. ELSE (LT B) .+ PLUS!-MOD!-P(A,RED B);
  5128. SYMBOLIC PROCEDURE TIMES!-MOD!-P(A,B);
  5129. IF (NULL A) OR (NULL B) THEN NIL
  5130. ELSE IF ISDOMAIN A THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(B,A)
  5131. ELSE IF ISDOMAIN B THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,B)
  5132. ELSE IF MVAR A=MVAR B THEN PLUS!-MOD!-P(
  5133. PLUS!-MOD!-P(TIMES!-TERM!-MOD!-P(LT A,B),
  5134. TIMES!-TERM!-MOD!-P(LT B,RED A)),
  5135. TIMES!-MOD!-P(RED A,RED B))
  5136. ELSE IF ORDOP(MVAR A,MVAR B) THEN
  5137. ADJOIN!-TERM(LPOW A,TIMES!-MOD!-P(LC A,B),TIMES!-MOD!-P(RED A,B))
  5138. ELSE ADJOIN!-TERM(LPOW B,
  5139. TIMES!-MOD!-P(A,LC B),TIMES!-MOD!-P(A,RED B));
  5140. SYMBOLIC PROCEDURE TIMES!-TERM!-MOD!-P(TERM,B);
  5141. %multiply the given polynomial by the given term;
  5142. IF NULL B THEN NIL
  5143. ELSE IF ISDOMAIN B THEN
  5144. ADJOIN!-TERM(TPOW TERM,
  5145. MULTIPLY!-BY!-CONSTANT!-MOD!-P(TC TERM,B),NIL)
  5146. ELSE IF TVAR TERM=MVAR B THEN
  5147. ADJOIN!-TERM(MKSP(TVAR TERM,IPLUS(TDEG TERM,LDEG B)),
  5148. TIMES!-MOD!-P(TC TERM,LC B),
  5149. TIMES!-TERM!-MOD!-P(TERM,RED B))
  5150. ELSE IF ORDOP(TVAR TERM,MVAR B) THEN
  5151. ADJOIN!-TERM(TPOW TERM,TIMES!-MOD!-P(TC TERM,B),NIL)
  5152. ELSE ADJOIN!-TERM(LPOW B,
  5153. TIMES!-TERM!-MOD!-P(TERM,LC B),
  5154. TIMES!-TERM!-MOD!-P(TERM,RED B));
  5155. SYMBOLIC PROCEDURE DIFFERENCE!-MOD!-P(A,B);
  5156. PLUS!-MOD!-P(A,MINUS!-MOD!-P B);
  5157. SYMBOLIC PROCEDURE MINUS!-MOD!-P A;
  5158. IF NULL A THEN NIL
  5159. ELSE IF ISDOMAIN A THEN MODULAR!-MINUS A
  5160. ELSE (LPOW A .* MINUS!-MOD!-P LC A) .+ MINUS!-MOD!-P RED A;
  5161. SYMBOLIC PROCEDURE REDUCE!-MOD!-P A;
  5162. %converts a multivariate poly from normal into modular polynomial;
  5163. IF NULL A THEN NIL
  5164. ELSE IF ISDOMAIN A THEN !*NUM2F MODULAR!-NUMBER A
  5165. ELSE ADJOIN!-TERM(LPOW A,REDUCE!-MOD!-P LC A,REDUCE!-MOD!-P RED A);
  5166. SYMBOLIC PROCEDURE MONIC!-MOD!-P A;
  5167. % This procedure can only cope with polys that have a numeric
  5168. % leading coeff;
  5169. IF A=NIL THEN NIL
  5170. ELSE IF ISDOMAIN A THEN 1
  5171. ELSE IF LC A = 1 THEN A
  5172. ELSE IF NOT DOMAINP LC A THEN
  5173. ERRORF "LC NOT NUMERIC IN MONIC-MOD-P"
  5174. ELSE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,
  5175. MODULAR!-RECIPROCAL LC A);
  5176. SYMBOLIC PROCEDURE QUOTFAIL!-MOD!-P(A,B);
  5177. % Form quotient A/B, but complain if the division is
  5178. % not exact;
  5179. BEGIN
  5180. SCALAR C;
  5181. EXACT!-QUOTIENT!-FLAG:=T;
  5182. C:=QUOTIENT!-MOD!-P(A,B);
  5183. IF EXACT!-QUOTIENT!-FLAG THEN RETURN C
  5184. ELSE ERRORF "QUOTIENT NOT EXACT (MOD P)"
  5185. END;
  5186. SYMBOLIC PROCEDURE QUOTIENT!-MOD!-P(A,B);
  5187. % truncated quotient of a by b;
  5188. IF NULL B THEN ERRORF "B=0 IN QUOTIENT-MOD-P"
  5189. ELSE IF ISDOMAIN B THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,
  5190. MODULAR!-RECIPROCAL B)
  5191. ELSE IF A=NIL THEN NIL
  5192. ELSE IF ISDOMAIN A THEN EXACT!-QUOTIENT!-FLAG:=NIL
  5193. ELSE IF MVAR A=MVAR B THEN XQUOTIENT!-MOD!-P(A,B,MVAR B)
  5194. ELSE IF ORDOP(MVAR A,MVAR B) THEN
  5195. ADJOIN!-TERM(LPOW A,
  5196. QUOTIENT!-MOD!-P(LC A,B),
  5197. QUOTIENT!-MOD!-P(RED A,B))
  5198. ELSE EXACT!-QUOTIENT!-FLAG:=NIL;
  5199. SYMBOLIC PROCEDURE XQUOTIENT!-MOD!-P(A,B,V);
  5200. % truncated quotient a/b given that b is nontrivial;
  5201. IF A=NIL THEN NIL
  5202. ELSE IF (ISDOMAIN A) OR (NOT MVAR A=V) OR
  5203. ILESSP(LDEG A,LDEG B) THEN EXACT!-QUOTIENT!-FLAG:=NIL
  5204. ELSE IF LDEG A = LDEG B THEN BEGIN SCALAR W;
  5205. W:=QUOTIENT!-MOD!-P(LC A,LC B);
  5206. IF DIFFERENCE!-MOD!-P(A,TIMES!-MOD!-P(W,B)) THEN
  5207. EXACT!-QUOTIENT!-FLAG:=NIL;
  5208. RETURN W
  5209. END
  5210. ELSE BEGIN SCALAR TERM;
  5211. TERM:=MKSP(MVAR A,IDIFFERENCE(LDEG A,LDEG B)) .*
  5212. QUOTIENT!-MOD!-P(LC A,LC B);
  5213. %that is the leading term of the quotient. now subtract
  5214. %term*b from a;
  5215. A:=PLUS!-MOD!-P(RED A,
  5216. TIMES!-TERM!-MOD!-P(NEGATE!-TERM TERM,RED B));
  5217. % or a:=a-b*term given leading terms must cancel;
  5218. RETURN TERM .+ XQUOTIENT!-MOD!-P(A,B,V)
  5219. END;
  5220. SYMBOLIC PROCEDURE NEGATE!-TERM TERM;
  5221. % negate a term;
  5222. TPOW TERM .* MINUS!-MOD!-P TC TERM;
  5223. SYMBOLIC PROCEDURE REMAINDER!-MOD!-P(A,B);
  5224. % remainder when a is divided by b;
  5225. IF NULL B THEN ERRORF "B=0 IN REMAINDER-MOD-P"
  5226. ELSE IF ISDOMAIN B THEN NIL
  5227. ELSE IF ISDOMAIN A THEN A
  5228. ELSE XREMAINDER!-MOD!-P(A,B,MVAR B);
  5229. SYMBOLIC PROCEDURE XREMAINDER!-MOD!-P(A,B,V);
  5230. % remainder when the modular polynomial a is
  5231. % divided by b, given that b is non degenerate;
  5232. IF (ISDOMAIN A) OR (NOT MVAR A=V) OR ILESSP(LDEG A,LDEG B) THEN A
  5233. ELSE BEGIN
  5234. SCALAR Q,W;
  5235. Q:=QUOTIENT!-MOD!-P(MINUS!-MOD!-P LC A,LC B);
  5236. % compute -lc of quotient;
  5237. W:=IDIFFERENCE(LDEG A,LDEG B); %ldeg of quotient;
  5238. IF W=0 THEN A:=PLUS!-MOD!-P(RED A,
  5239. MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED B,Q))
  5240. ELSE
  5241. A:=PLUS!-MOD!-P(RED A,TIMES!-TERM!-MOD!-P(
  5242. MKSP(MVAR B,W) .* Q,RED B));
  5243. % the above lines of code use red a and red b because
  5244. % by construction the leading terms of the required
  5245. % answers will cancel out;
  5246. RETURN XREMAINDER!-MOD!-P(A,B,V)
  5247. END;
  5248. SYMBOLIC PROCEDURE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,N);
  5249. % multiply the polynomial a by the constant n;
  5250. IF NULL A THEN NIL
  5251. ELSE IF N=1 THEN A
  5252. ELSE IF ISDOMAIN A THEN !*NUM2F MODULAR!-TIMES(A,N)
  5253. ELSE ADJOIN!-TERM(LPOW A,MULTIPLY!-BY!-CONSTANT!-MOD!-P(LC A,N),
  5254. MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED A,N));
  5255. SYMBOLIC PROCEDURE GCD!-MOD!-P(A,B);
  5256. % return the monic gcd of the two modular univariate
  5257. % polynomials a and b. Set REDUCTION-COUNT to the number
  5258. % of steps taken in the process;
  5259. << REDUCTION!-COUNT := 0;
  5260. IF NULL A THEN MONIC!-MOD!-P B
  5261. ELSE IF NULL B THEN MONIC!-MOD!-P A
  5262. ELSE IF ISDOMAIN A THEN 1
  5263. ELSE IF ISDOMAIN B THEN 1
  5264. ELSE IF IGREATERP(LDEG A,LDEG B) THEN
  5265. ORDERED!-GCD!-MOD!-P(A,B)
  5266. ELSE ORDERED!-GCD!-MOD!-P(B,A) >>;
  5267. SYMBOLIC PROCEDURE ORDERED!-GCD!-MOD!-P(A,B);
  5268. % as above, but deg a > deg b;
  5269. BEGIN
  5270. SCALAR STEPS;
  5271. STEPS := 0;
  5272. TOP:
  5273. A := REDUCE!-DEGREE!-MOD!-P(A,B);
  5274. IF NULL A THEN RETURN MONIC!-MOD!-P B;
  5275. STEPS := STEPS + 1;
  5276. IF DOMAINP A THEN <<
  5277. REDUCTION!-COUNT := REDUCTION!-COUNT+STEPS;
  5278. RETURN 1 >>
  5279. ELSE IF LDEG A<LDEG B THEN BEGIN
  5280. SCALAR W;
  5281. REDUCTION!-COUNT := REDUCTION!-COUNT + STEPS;
  5282. STEPS := 0;
  5283. W := A; A := B; B := W
  5284. END;
  5285. GO TO TOP
  5286. END;
  5287. SYMBOLIC PROCEDURE REDUCE!-DEGREE!-MOD!-P(A,B);
  5288. % Compute A-Q*B where Q is a single term chosen so that the result
  5289. % has lower degree than A did;
  5290. BEGIN
  5291. SCALAR Q,W;
  5292. Q:=MODULAR!-QUOTIENT(MODULAR!-MINUS LC A,LC B);
  5293. % compute -lc of quotient;
  5294. W:=IDIFFERENCE(LDEG A,LDEG B); %ldeg of quotient;
  5295. % the next lines of code use red a and red b because
  5296. % by construction the leading terms of the required
  5297. % answers will cancel out;
  5298. IF W=0 THEN RETURN PLUS!-MOD!-P(RED A,
  5299. MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED B,Q))
  5300. ELSE
  5301. RETURN PLUS!-MOD!-P(RED A,TIMES!-TERM!-MOD!-P(
  5302. MKSP(MVAR B,W) .* Q,RED B))
  5303. END;
  5304. SYMBOLIC PROCEDURE DERIVATIVE!-MOD!-P A;
  5305. % derivative of a wrt its main variable;
  5306. IF ISDOMAIN A THEN NIL
  5307. ELSE IF LDEG A=1 THEN LC A
  5308. ELSE DERIVATIVE!-MOD!-P!-1(A,MVAR A);
  5309. SYMBOLIC PROCEDURE DERIVATIVE!-MOD!-P!-1(A,V);
  5310. IF ISDOMAIN A THEN NIL
  5311. ELSE IF NOT MVAR A=V THEN NIL
  5312. ELSE IF LDEG A=1 THEN LC A
  5313. ELSE ADJOIN!-TERM(MKSP(V,ISUB1 LDEG A),
  5314. MULTIPLY!-BY!-CONSTANT!-MOD!-P(LC A,
  5315. MODULAR!-NUMBER LDEG A),
  5316. DERIVATIVE!-MOD!-P!-1(RED A,V));
  5317. SYMBOLIC PROCEDURE SQUARE!-FREE!-MOD!-P A;
  5318. % predicate that tests if a is square-free as a modular
  5319. % univariate polynomial;
  5320. IF ISDOMAIN A THEN T
  5321. ELSE ISDOMAIN GCD!-MOD!-P(A,DERIVATIVE!-MOD!-P A);
  5322. SYMBOLIC PROCEDURE EVALUATE!-MOD!-P(A,V,N);
  5323. % evaluate polynomial A at the point V=N;
  5324. IF ISDOMAIN A THEN A
  5325. ELSE IF V=NIL THEN ERRORF "Variable=NIL in EVALUATE-MOD-P"
  5326. ELSE IF MVAR A=V THEN HORNER!-RULE!-MOD!-P(LC A,LDEG A,RED A,N,V)
  5327. ELSE ADJOIN!-TERM(LPOW A,
  5328. EVALUATE!-MOD!-P(LC A,V,N),
  5329. EVALUATE!-MOD!-P(RED A,V,N));
  5330. SYMBOLIC PROCEDURE HORNER!-RULE!-MOD!-P(V,DEGG,A,N,VAR);
  5331. % v is the running total, and it must be multiplied by
  5332. % n**deg and added to the value of a at n;
  5333. IF ISDOMAIN A OR NOT MVAR A=VAR THEN <<
  5334. V:=TIMES!-MOD!-P(V,EXPT!-MOD!-P(N,DEGG));
  5335. PLUS!-MOD!-P(A,V) >>
  5336. ELSE BEGIN
  5337. SCALAR NEWDEG;
  5338. NEWDEG:=LDEG A;
  5339. RETURN HORNER!-RULE!-MOD!-P(PLUS!-MOD!-P(LC A,
  5340. TIMES!-MOD!-P(V,EXPT!-MOD!-P(N,IDIFFERENCE(DEGG,NEWDEG)))),
  5341. NEWDEG,RED A,N,VAR)
  5342. END;
  5343. SYMBOLIC PROCEDURE EXPT!-MOD!-P(A,N);
  5344. % a**n;
  5345. IF N=0 THEN 1
  5346. ELSE IF N=1 THEN A
  5347. ELSE BEGIN
  5348. SCALAR W,X;
  5349. W:=DIVIDE(N,2);
  5350. X:=EXPT!-MOD!-P(A,CAR W);
  5351. X:=TIMES!-MOD!-P(X,X);
  5352. IF NOT (CDR W = 0) THEN X:=TIMES!-MOD!-P(X,A);
  5353. RETURN X
  5354. END;
  5355. SYMBOLIC PROCEDURE MAKE!-BIVARIATE!-MOD!-P(U,IMSET,V);
  5356. % Substitute into U for all variables in IMSET which should result in
  5357. % a bivariate poly. One variable is M-IMAGE-VARIABLE and V is the other
  5358. % U is modular multivariate with these two variables at top 2 levels
  5359. % - V at 2nd level;
  5360. IF DOMAINP U THEN U
  5361. ELSE IF MVAR U = M!-IMAGE!-VARIABLE THEN
  5362. ADJOIN!-TERM(LPOW U,MAKE!-UNIVARIATE!-MOD!-P(LC U,IMSET,V),
  5363. MAKE!-BIVARIATE!-MOD!-P(RED U,IMSET,V))
  5364. ELSE MAKE!-UNIVARIATE!-MOD!-P(U,IMSET,V);
  5365. SYMBOLIC PROCEDURE MAKE!-UNIVARIATE!-MOD!-P(U,IMSET,V);
  5366. % Substitute into U for all variables in IMSET giving a univariate
  5367. % poly in V. U is modular multivariate with V at top level;
  5368. IF DOMAINP U THEN U
  5369. ELSE IF MVAR U = V THEN
  5370. ADJOIN!-TERM(LPOW U,!*NUM2F EVALUATE!-IN!-ORDER!-MOD!-P(LC U,IMSET),
  5371. MAKE!-UNIVARIATE!-MOD!-P(RED U,IMSET,V))
  5372. ELSE !*NUM2F EVALUATE!-IN!-ORDER!-MOD!-P(U,IMSET);
  5373. SYMBOLIC PROCEDURE EVALUATE!-IN!-ORDER!-MOD!-P(U,IMSET);
  5374. % makes an image of u wrt imageset, imset, using horner's rule. result
  5375. % should be purely numeric (and modular);
  5376. IF DOMAINP U THEN !*D2N U
  5377. ELSE IF MVAR U=CAAR IMSET THEN
  5378. HORNER!-RULE!-IN!-ORDER!-MOD!-P(
  5379. EVALUATE!-IN!-ORDER!-MOD!-P(LC U,CDR IMSET),LDEG U,RED U,IMSET)
  5380. ELSE EVALUATE!-IN!-ORDER!-MOD!-P(U,CDR IMSET);
  5381. SYMBOLIC PROCEDURE HORNER!-RULE!-IN!-ORDER!-MOD!-P(C,DEGG,A,VSET);
  5382. % c is running total and a is what is left;
  5383. IF DOMAINP A THEN MODULAR!-PLUS(!*D2N A,
  5384. MODULAR!-TIMES(C,MODULAR!-EXPT(CDAR VSET,DEGG)))
  5385. ELSE IF NOT(MVAR A=CAAR VSET) THEN
  5386. MODULAR!-PLUS(
  5387. EVALUATE!-IN!-ORDER!-MOD!-P(A,CDR VSET),
  5388. MODULAR!-TIMES(C,MODULAR!-EXPT(CDAR VSET,DEGG)))
  5389. ELSE BEGIN SCALAR NEWDEG;
  5390. NEWDEG:=LDEG A;
  5391. RETURN HORNER!-RULE!-IN!-ORDER!-MOD!-P(
  5392. MODULAR!-PLUS(
  5393. EVALUATE!-IN!-ORDER!-MOD!-P(LC A,CDR VSET),
  5394. MODULAR!-TIMES(C,
  5395. MODULAR!-EXPT(CDAR VSET,(IDIFFERENCE(DEGG,NEWDEG))))),
  5396. NEWDEG,RED A,VSET)
  5397. END;
  5398. SYMBOLIC PROCEDURE MAKE!-MODULAR!-SYMMETRIC A;
  5399. % input is a multivariate MODULAR poly A with nos in the range 0->(p-1).
  5400. % This folds it onto the symmetric range (-p/2)->(p/2);
  5401. IF NULL A THEN NIL
  5402. ELSE IF DOMAINP A THEN
  5403. IF A>MODULUS!/2 THEN !*NUM2F(A - CURRENT!-MODULUS)
  5404. ELSE A
  5405. ELSE ADJOIN!-TERM(LPOW A,MAKE!-MODULAR!-SYMMETRIC LC A,
  5406. MAKE!-MODULAR!-SYMMETRIC RED A);
  5407. ENDMODULE;
  5408. MODULE MULTIHEN;
  5409. % *******************************************************************
  5410. %
  5411. % copyright (c) university of cambridge, england 1979
  5412. %
  5413. % *******************************************************************;
  5414. %**********************************************************************;
  5415. % hensel construction for the multivariate case
  5416. % (this version is highly recursive);
  5417. SYMBOLIC PROCEDURE FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(POLY,
  5418. BEST!-FACTORS,VARIABLE!-SET);
  5419. % All arithmetic is done mod p, best-factors is overwritten;
  5420. IF NULL VARIABLE!-SET THEN BEST!-FACTORS
  5421. ELSE (LAMBDA FACTOR!-LEVEL; BEGIN
  5422. SCALAR GROWTH!-FACTOR,B0S,RES,CORRECTION!-FACTOR,SUBSTRES,V,
  5423. B1,BHAT0S,W,K,DEGBD,FIRST!-TIME,REDPOLY,D,
  5424. PREDICTED!-FORMS,NUMBER!-OF!-UNKNOWNS,SOLVE!-COUNT,
  5425. CORRECTION!-VECTORS,SOLN!-MATRICES,MAX!-UNKNOWNS,
  5426. UNKNOWNS!-COUNT!-LIST,TEST!-PREDICTION,POLY!-REMAINING,
  5427. PREDICTION!-RESULTS,ONE!-PREDICTION!-FAILED,KK;
  5428. V:=CAR VARIABLE!-SET;
  5429. DEGBD:=GET!-DEGREE!-BOUND CAR V;
  5430. FIRST!-TIME:=T;
  5431. GROWTH!-FACTOR:=MAKE!-GROWTH!-FACTOR V;
  5432. POLY!-REMAINING:=POLY;
  5433. PREDICTION!-RESULTS:=MKVECT NUMBER!-OF!-FACTORS;
  5434. FACTOR!-TRACE <<
  5435. PRINTSTR "Want f(i) s.t.";
  5436. PRIN2!* " product over i [ f(i) ] = ";
  5437. PRINSF POLY;
  5438. PRIN2!* " mod ";
  5439. PRINTSTR HENSEL!-GROWTH!-SIZE;
  5440. TERPRI!*(NIL);
  5441. PRINTSTR "We know f(i) as follows:";
  5442. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS);
  5443. PRIN2!* " and we shall put in powers of ";
  5444. PRINSF GROWTH!-FACTOR;
  5445. PRINTSTR " to find them fully."
  5446. >>;
  5447. B0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(BEST!-FACTORS,
  5448. V,NUMBER!-OF!-FACTORS);
  5449. % The above made a copy of the vector;
  5450. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5451. PUTV(BEST!-FACTORS,I,
  5452. DIFFERENCE!-MOD!-P(GETV(BEST!-FACTORS,I),GETV(B0S,I)));
  5453. REDPOLY:=EVALUATE!-MOD!-P(POLY,CAR V,CDR V);
  5454. FACTOR!-TRACE <<
  5455. PRIN2!*
  5456. "First solve the problem in one less variable by putting ";
  5457. PRINVAR CAR V; PRIN2!* "="; PRINTSTR CDR V;
  5458. IF CDR VARIABLE!-SET THEN <<
  5459. PRIN2!* "and growing wrt ";
  5460. PRINTVAR CAADR VARIABLE!-SET
  5461. >>;
  5462. TERPRI!*(NIL)
  5463. >>;
  5464. FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(REDPOLY,B0S,CDR VARIABLE!-SET);
  5465. % answers in b0s;
  5466. IF BAD!-CASE THEN RETURN;
  5467. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5468. PUTV(BEST!-FACTORS,I,
  5469. PLUS!-MOD!-P(GETV(B0S,I),GETV(BEST!-FACTORS,I)));
  5470. FACTOR!-TRACE <<
  5471. PRIN2!* "After putting back any knowledge of ";
  5472. PRINVAR CAR V;
  5473. PRINTSTR ", we have the";
  5474. PRINTSTR "factors so far as:";
  5475. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS);
  5476. PRINTSTR "Subtracting the product of these from the polynomial";
  5477. PRIN2!* "and differentiating wrt "; PRINVAR CAR V;
  5478. PRINTSTR " gives a residue:"
  5479. >>;
  5480. RES:=DIFF!-OVER!-K!-MOD!-P(
  5481. DIFFERENCE!-MOD!-P(POLY,
  5482. TIMES!-VECTOR!-MOD!-P(BEST!-FACTORS,NUMBER!-OF!-FACTORS)),
  5483. 1,CAR V);
  5484. % RES is the residue and must eventually be reduced to zero;
  5485. FACTOR!-TRACE << FAC!-PRINTSF RES; TERPRI!*(NIL) >>;
  5486. IF NOT POLYZEROP RES AND
  5487. CDR VARIABLE!-SET AND NOT ZEROP CDR V THEN <<
  5488. PREDICTED!-FORMS:=MAKE!-BIVARIATE!-VEC!-MOD!-P(BEST!-FACTORS,
  5489. CDR VARIABLE!-SET,CAR V,NUMBER!-OF!-FACTORS);
  5490. FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(
  5491. MAKE!-BIVARIATE!-MOD!-P(POLY,CDR VARIABLE!-SET,CAR V),
  5492. PREDICTED!-FORMS,LIST V);
  5493. % answers in PREDICTED!-FORMS;
  5494. FACTOR!-TRACE <<
  5495. PRINTSTR "To help reduce the number of Hensel steps we try";
  5496. PRIN2!* "predicting how many terms each factor will have wrt ";
  5497. PRINVAR CAR V; PRINTSTR ".";
  5498. PRINTSTR
  5499. "Predictions are based on the bivariate factors :";
  5500. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",PREDICTED!-FORMS)
  5501. >>;
  5502. MAKE!-PREDICTED!-FORMS(PREDICTED!-FORMS,CAR V);
  5503. % sets max!-unknowns and number!-of!-unknowns;
  5504. FACTOR!-TRACE <<
  5505. TERPRI!*(NIL);
  5506. PRINTSTR "We predict :";
  5507. FOR EACH W IN NUMBER!-OF!-UNKNOWNS DO <<
  5508. PRIN2!* CAR W;
  5509. PRIN2!* " terms in f("; PRIN2!* CDR W; PRINTSTR '!) >>;
  5510. IF (CAAR NUMBER!-OF!-UNKNOWNS)=1 THEN <<
  5511. PRIN2!* "Since we predict only one term for f(";
  5512. PRIN2!* CDAR NUMBER!-OF!-UNKNOWNS;
  5513. PRINTSTR "), we can try";
  5514. PRINTSTR "dividing it out now:" >>
  5515. ELSE <<
  5516. PRIN2!* "So we shall do at least ";
  5517. PRIN2!* ISUB1 CAAR NUMBER!-OF!-UNKNOWNS;
  5518. PRIN2!* " Hensel step";
  5519. IF (CAAR NUMBER!-OF!-UNKNOWNS)=2 THEN PRINTSTR "."
  5520. ELSE PRINTSTR "s." >>;
  5521. TERPRI!*(NIL) >>;
  5522. UNKNOWNS!-COUNT!-LIST:=NUMBER!-OF!-UNKNOWNS;
  5523. WHILE UNKNOWNS!-COUNT!-LIST AND
  5524. (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=1 DO
  5525. BEGIN SCALAR I,R;
  5526. UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST;
  5527. I:=CDR W;
  5528. W:=QUOTIENT!-MOD!-P(POLY!-REMAINING,R:=GETV(BEST!-FACTORS,I));
  5529. IF DIDNTGO W OR
  5530. NOT POLYZEROP DIFFERENCE!-MOD!-P(POLY!-REMAINING,
  5531. TIMES!-MOD!-P(W,R)) THEN
  5532. IF ONE!-PREDICTION!-FAILED THEN <<
  5533. FACTOR!-TRACE PRINTSTR "Predictions are no good";
  5534. MAX!-UNKNOWNS:=NIL >>
  5535. ELSE <<
  5536. FACTOR!-TRACE <<
  5537. PRIN2!* "Guess for f(";
  5538. PRIN2!* I;
  5539. PRINTSTR ") was bad." >>;
  5540. ONE!-PREDICTION!-FAILED:=I >>
  5541. ELSE <<
  5542. PUTV(PREDICTION!-RESULTS,I,R);
  5543. FACTOR!-TRACE <<
  5544. PRIN2!* "Prediction for f("; PRIN2!* I;
  5545. PRIN2!* ") worked: ";
  5546. FAC!-PRINTSF R >>;
  5547. POLY!-REMAINING:=W >>
  5548. END;
  5549. W:=LENGTH UNKNOWNS!-COUNT!-LIST;
  5550. IF W=1 AND NOT ONE!-PREDICTION!-FAILED THEN <<
  5551. PUTV(BEST!-FACTORS,CDAR UNKNOWNS!-COUNT!-LIST,POLY!-REMAINING);
  5552. GOTO EXIT >>
  5553. ELSE IF W=0 AND ONE!-PREDICTION!-FAILED THEN <<
  5554. PUTV(BEST!-FACTORS,ONE!-PREDICTION!-FAILED,POLY!-REMAINING);
  5555. GOTO EXIT >>;
  5556. SOLVE!-COUNT:=1;
  5557. IF MAX!-UNKNOWNS THEN
  5558. CORRECTION!-VECTORS:=MAKE!-CORRECTION!-VECTORS(PREDICTED!-FORMS,
  5559. BEST!-FACTORS,MAX!-UNKNOWNS) >>;
  5560. BHAT0S:=MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(B0S,NUMBER!-OF!-FACTORS);
  5561. K:=1;
  5562. KK:=0;
  5563. CORRECTION!-FACTOR:=GROWTH!-FACTOR;
  5564. % next power of growth-factor we are
  5565. % adding to the factors;
  5566. B1:=MKVECT NUMBER!-OF!-FACTORS;
  5567. TEMPLOOP:
  5568. WHILE NOT POLYZEROP RES AND (NULL MAX!-UNKNOWNS
  5569. OR NULL TEST!-PREDICTION) DO
  5570. IF K>DEGBD THEN RETURN <<
  5571. FACTOR!-TRACE <<
  5572. PRIN2!* "We have overshot the degree bound for ";
  5573. PRINTVAR CAR V >>;
  5574. IF !*OVERSHOOT THEN
  5575. PRINTC "Multivariate degree bound overshoot -> restart";
  5576. BAD!-CASE:=T >>
  5577. ELSE
  5578. IF POLYZEROP(SUBSTRES:=EVALUATE!-MOD!-P(RES,CAR V,CDR V))
  5579. THEN <<
  5580. K:=IADD1 K;
  5581. RES:=DIFF!-OVER!-K!-MOD!-P(RES,K,CAR V);
  5582. CORRECTION!-FACTOR:=
  5583. TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>
  5584. ELSE <<
  5585. FACTOR!-TRACE <<
  5586. PRIN2!* "Hensel Step "; PRINTSTR (KK:=KK #+ 1);
  5587. PRIN2!* "-------------";
  5588. IF KK>10 THEN PRINTSTR "-" ELSE TERPRI!*(T);
  5589. PRIN2!* "Next corrections are for (";
  5590. PRINSF GROWTH!-FACTOR;
  5591. IF NOT (K=1) THEN <<
  5592. PRIN2!* ") ** ";
  5593. PRIN2!* K >> ELSE PRIN2!* '!);
  5594. PRINTSTR ". To find these we solve:";
  5595. PRIN2!* " sum over i [ f(i,1)*fhat(i,0) ] = ";
  5596. PRINSF SUBSTRES;
  5597. PRIN2!* " mod ";
  5598. PRIN2!* HENSEL!-GROWTH!-SIZE;
  5599. PRINTSTR " for f(i,1), ";
  5600. IF FIRST!-TIME THEN <<
  5601. FIRST!-TIME:=NIL;
  5602. PRIN2!*
  5603. " where fhat(i,0) = product over j [ f(j,0) ]";
  5604. PRIN2!* " / f(i,0) mod ";
  5605. PRINTSTR HENSEL!-GROWTH!-SIZE >>;
  5606. TERPRI!*(NIL)
  5607. >>;
  5608. SOLVE!-FOR!-CORRECTIONS(SUBSTRES,BHAT0S,B0S,B1,
  5609. CDR VARIABLE!-SET);
  5610. % Answers left in B1;
  5611. IF BAD!-CASE THEN RETURN;
  5612. IF MAX!-UNKNOWNS THEN <<
  5613. SOLVE!-COUNT:=IADD1 SOLVE!-COUNT;
  5614. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5615. PUTV(GETV(CORRECTION!-VECTORS,I),SOLVE!-COUNT,GETV(B1,I));
  5616. IF SOLVE!-COUNT=CAAR UNKNOWNS!-COUNT!-LIST THEN
  5617. TEST!-PREDICTION:=T >>;
  5618. FACTOR!-TRACE <<
  5619. PRINTSTR " Giving:";
  5620. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,",1) = ",B1) >>;
  5621. D:=TIMES!-MOD!-P(CORRECTION!-FACTOR,
  5622. TERMS!-DONE!-MOD!-P(BEST!-FACTORS,B1,CORRECTION!-FACTOR));
  5623. IF DEGREE!-IN!-VARIABLE(D,CAR V)>DEGBD THEN RETURN <<
  5624. FACTOR!-TRACE <<
  5625. PRIN2!* "We have overshot the degree bound for ";
  5626. PRINTVAR CAR V >>;
  5627. IF !*OVERSHOOT THEN
  5628. PRINTC "Multivariate degree bound overshoot -> restart";
  5629. BAD!-CASE:=T >>;
  5630. D:=DIFF!-K!-TIMES!-MOD!-P(D,K,CAR V);
  5631. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5632. PUTV(BEST!-FACTORS,I,
  5633. PLUS!-MOD!-P(GETV(BEST!-FACTORS,I),
  5634. TIMES!-MOD!-P(GETV(B1,I),CORRECTION!-FACTOR)));
  5635. K:=IADD1 K;
  5636. RES:=DIFF!-OVER!-K!-MOD!-P(DIFFERENCE!-MOD!-P(RES,D),K,CAR V);
  5637. FACTOR!-TRACE <<
  5638. PRINTSTR " New factors are now:";
  5639. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS);
  5640. PRIN2!* " and residue = ";
  5641. FAC!-PRINTSF RES;
  5642. PRINTSTR "-------------"
  5643. >>;
  5644. CORRECTION!-FACTOR:=
  5645. TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>;
  5646. IF NOT POLYZEROP RES AND NOT BAD!-CASE THEN <<
  5647. SOLN!-MATRICES:=CONSTRUCT!-SOLN!-MATRICES(PREDICTED!-FORMS,CDR V);
  5648. FACTOR!-TRACE <<
  5649. PRINTSTR "We use the results from the Hensel growth to";
  5650. PRINTSTR "produce a set of linear equations to solve";
  5651. PRINTSTR "for coefficients in the relevent factors:" >>;
  5652. WHILE UNKNOWNS!-COUNT!-LIST AND
  5653. (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=SOLVE!-COUNT DO <<
  5654. UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST;
  5655. FACTOR!-TRACE
  5656. PRINT!-LINEAR!-SYSTEM(CDR W,SOLN!-MATRICES,
  5657. CORRECTION!-VECTORS,PREDICTED!-FORMS,CAR V);
  5658. W:=TRY!-PREDICTION(SOLN!-MATRICES,CORRECTION!-VECTORS,
  5659. PREDICTED!-FORMS,CAR W,CDR W,POLY!-REMAINING,CAR V,
  5660. NIL,NIL,NIL);
  5661. IF CAR W='SINGULAR OR CAR W='BAD!-PREDICTION THEN
  5662. IF ONE!-PREDICTION!-FAILED THEN <<
  5663. FACTOR!-TRACE PRINTSTR "Predictions were no help.";
  5664. RETURN MAX!-UNKNOWNS:=NIL >>
  5665. ELSE ONE!-PREDICTION!-FAILED:=CDR W
  5666. ELSE <<
  5667. PUTV(PREDICTION!-RESULTS,CAR W,CADR W);
  5668. POLY!-REMAINING:=CADDR W >> >>;
  5669. IF NULL MAX!-UNKNOWNS THEN GOTO TEMPLOOP;
  5670. W:=LENGTH UNKNOWNS!-COUNT!-LIST;
  5671. IF W>1 OR (W=1 AND ONE!-PREDICTION!-FAILED) THEN <<
  5672. TEST!-PREDICTION:=NIL;
  5673. GOTO TEMPLOOP >>;
  5674. IF W=1 OR ONE!-PREDICTION!-FAILED THEN <<
  5675. W:=IF ONE!-PREDICTION!-FAILED THEN ONE!-PREDICTION!-FAILED
  5676. ELSE CDAR UNKNOWNS!-COUNT!-LIST;
  5677. PUTV(PREDICTION!-RESULTS,W,POLY!-REMAINING) >>;
  5678. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5679. PUTV(BEST!-FACTORS,I,GETV(PREDICTION!-RESULTS,I));
  5680. IF NOT ONE!-PREDICTION!-FAILED THEN
  5681. PREDICTIONS:=
  5682. (CAR V .
  5683. LIST(SOLN!-MATRICES,PREDICTED!-FORMS,MAX!-UNKNOWNS,
  5684. NUMBER!-OF!-UNKNOWNS))
  5685. . PREDICTIONS >>;
  5686. EXIT:
  5687. FACTOR!-TRACE <<
  5688. IF NOT BAD!-CASE THEN
  5689. IF FIRST!-TIME THEN
  5690. PRINTSTR "Therefore these factors are already correct."
  5691. ELSE <<
  5692. PRINTSTR "Correct factors are:";
  5693. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS)
  5694. >>;
  5695. TERPRI!*(NIL);
  5696. PRINTSTR "******************************************************";
  5697. TERPRI!*(NIL) >>
  5698. END) (FACTOR!-LEVEL+1);
  5699. SYMBOLIC PROCEDURE SOLVE!-FOR!-CORRECTIONS(C,FHATVEC,FVEC,RESVEC,VSET);
  5700. % ....;
  5701. IF NULL VSET THEN
  5702. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5703. PUTV(RESVEC,I,
  5704. REMAINDER!-MOD!-P(
  5705. TIMES!-MOD!-P(C,GETV(ALPHAVEC,I)),
  5706. GETV(FVEC,I)))
  5707. ELSE (LAMBDA FACTOR!-LEVEL; BEGIN
  5708. SCALAR RESIDUE,GROWTH!-FACTOR,F0S,FHAT0S,V,F1,
  5709. CORRECTION!-FACTOR,SUBSTRES,K,DEGBD,FIRST!-TIME,REDC,D,
  5710. PREDICTED!-FORMS,MAX!-UNKNOWNS,SOLVE!-COUNT,NUMBER!-OF!-UNKNOWNS,
  5711. CORRECTION!-VECTORS,SOLN!-MATRICES,W,PREVIOUS!-PREDICTION!-HOLDS,
  5712. UNKNOWNS!-COUNT!-LIST,TEST!-PREDICTION,POLY!-REMAINING,
  5713. PREDICTION!-RESULTS,ONE!-PREDICTION!-FAILED,KK;
  5714. V:=CAR VSET;
  5715. DEGBD:=GET!-DEGREE!-BOUND CAR V;
  5716. FIRST!-TIME:=T;
  5717. GROWTH!-FACTOR:=MAKE!-GROWTH!-FACTOR V;
  5718. POLY!-REMAINING:=C;
  5719. PREDICTION!-RESULTS:=MKVECT NUMBER!-OF!-FACTORS;
  5720. REDC:=EVALUATE!-MOD!-P(C,CAR V,CDR V);
  5721. FACTOR!-TRACE <<
  5722. PRINTSTR "Want a(i) s.t.";
  5723. PRIN2!* "(*) sum over i [ a(i)*fhat(i) ] = ";
  5724. PRINSF C;
  5725. PRIN2!* " mod ";
  5726. PRINTSTR HENSEL!-GROWTH!-SIZE;
  5727. PRIN2!* " where fhat(i) = product over j [ f(j) ]";
  5728. PRIN2!* " / f(i) mod ";
  5729. PRINTSTR HENSEL!-GROWTH!-SIZE;
  5730. PRINTSTR " and";
  5731. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",FVEC);
  5732. TERPRI!*(NIL);
  5733. PRIN2!*
  5734. "First solve the problem in one less variable by putting ";
  5735. PRINVAR CAR V; PRIN2!* '!=; PRINTSTR CDR V;
  5736. TERPRI!*(NIL)
  5737. >>;
  5738. SOLVE!-FOR!-CORRECTIONS(REDC,
  5739. FHAT0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(
  5740. FHATVEC,V,NUMBER!-OF!-FACTORS),
  5741. F0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(
  5742. FVEC,V,NUMBER!-OF!-FACTORS),
  5743. RESVEC,
  5744. CDR VSET); % Results left in RESVEC;
  5745. IF BAD!-CASE THEN RETURN;
  5746. FACTOR!-TRACE <<
  5747. PRINTSTR "Giving:";
  5748. PRINTVEC(" a(",NUMBER!-OF!-FACTORS,",0) = ",RESVEC);
  5749. PRINTSTR "Subtracting the contributions these give in (*) from";
  5750. PRIN2!* "the R.H.S. of (*) ";
  5751. PRIN2!* "and differentiating wrt "; PRINVAR CAR V;
  5752. PRINTSTR " gives a residue:"
  5753. >>;
  5754. RESIDUE:=DIFF!-OVER!-K!-MOD!-P(DIFFERENCE!-MOD!-P(C,
  5755. FORM!-SUM!-AND!-PRODUCT!-MOD!-P(RESVEC,FHATVEC,
  5756. NUMBER!-OF!-FACTORS)),1,CAR V);
  5757. FACTOR!-TRACE <<
  5758. FAC!-PRINTSF RESIDUE;
  5759. PRIN2!* " Now we shall put in the powers of ";
  5760. PRINSF GROWTH!-FACTOR;
  5761. PRINTSTR " to find the a's fully."
  5762. >>;
  5763. IF NOT POLYZEROP RESIDUE AND NOT ZEROP CDR V THEN <<
  5764. W:=ATSOC(CAR V,PREDICTIONS);
  5765. IF W THEN <<
  5766. PREVIOUS!-PREDICTION!-HOLDS:=T;
  5767. FACTOR!-TRACE <<
  5768. PRINTSTR
  5769. "We shall use the previous prediction for the form of";
  5770. PRIN2!* "polynomials wrt "; PRINTVAR CAR V >>;
  5771. W:=CDR W;
  5772. SOLN!-MATRICES:=CAR W;
  5773. PREDICTED!-FORMS:=CADR W;
  5774. MAX!-UNKNOWNS:=CADDR W;
  5775. NUMBER!-OF!-UNKNOWNS:=CADR CDDR W >>
  5776. ELSE <<
  5777. FACTOR!-TRACE <<
  5778. PRINTSTR
  5779. "We shall use a new prediction for the form of polynomials ";
  5780. PRIN2!* "wrt "; PRINTVAR CAR V >>;
  5781. PREDICTED!-FORMS:=MKVECT NUMBER!-OF!-FACTORS;
  5782. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5783. PUTV(PREDICTED!-FORMS,I,GETV(FVEC,I));
  5784. % make a copy of the factors in a vector that we shall
  5785. % overwrite;
  5786. MAKE!-PREDICTED!-FORMS(PREDICTED!-FORMS,CAR V);
  5787. % sets max!-unknowns and number!-of!-unknowns;
  5788. >>;
  5789. FACTOR!-TRACE <<
  5790. TERPRI!*(NIL);
  5791. PRINTSTR "We predict :";
  5792. FOR EACH W IN NUMBER!-OF!-UNKNOWNS DO <<
  5793. PRIN2!* CAR W;
  5794. PRIN2!* " terms in a("; PRIN2!* CDR W; PRINTSTR '!) >>;
  5795. IF (CAAR NUMBER!-OF!-UNKNOWNS)=1 THEN <<
  5796. PRIN2!* "Since we predict only one term for a(";
  5797. PRIN2!* CDAR NUMBER!-OF!-UNKNOWNS;
  5798. PRINTSTR "), we can test it right away:" >>
  5799. ELSE <<
  5800. PRIN2!* "So we shall do at least ";
  5801. PRIN2!* ISUB1 CAAR NUMBER!-OF!-UNKNOWNS;
  5802. PRIN2!* " Hensel step";
  5803. IF (CAAR NUMBER!-OF!-UNKNOWNS)=2 THEN PRINTSTR "."
  5804. ELSE PRINTSTR "s." >>;
  5805. TERPRI!*(NIL) >>;
  5806. UNKNOWNS!-COUNT!-LIST:=NUMBER!-OF!-UNKNOWNS;
  5807. WHILE UNKNOWNS!-COUNT!-LIST AND
  5808. (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=1 DO
  5809. BEGIN SCALAR I,R,WR,FI;
  5810. UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST;
  5811. I:=CDR W;
  5812. W:=QUOTIENT!-MOD!-P(
  5813. WR:=DIFFERENCE!-MOD!-P(POLY!-REMAINING,
  5814. TIMES!-MOD!-P(R:=GETV(RESVEC,I),GETV(FHATVEC,I))),
  5815. FI:=GETV(FVEC,I));
  5816. IF DIDNTGO W OR NOT POLYZEROP
  5817. DIFFERENCE!-MOD!-P(WR,TIMES!-MOD!-P(W,FI)) THEN
  5818. IF ONE!-PREDICTION!-FAILED THEN <<
  5819. FACTOR!-TRACE PRINTSTR "Predictions are no good.";
  5820. MAX!-UNKNOWNS:=NIL >>
  5821. ELSE <<
  5822. FACTOR!-TRACE <<
  5823. PRIN2!* "Guess for a(";
  5824. PRIN2!* I;
  5825. PRINTSTR ") was bad." >>;
  5826. ONE!-PREDICTION!-FAILED:=I >>
  5827. ELSE <<
  5828. PUTV(PREDICTION!-RESULTS,I,R);
  5829. FACTOR!-TRACE <<
  5830. PRIN2!* "Prediction for a("; PRIN2!* I;
  5831. PRIN2!* ") worked: ";
  5832. FAC!-PRINTSF R >>;
  5833. POLY!-REMAINING:=WR >>
  5834. END;
  5835. W:=LENGTH UNKNOWNS!-COUNT!-LIST;
  5836. IF W=1 AND NOT ONE!-PREDICTION!-FAILED THEN <<
  5837. PUTV(RESVEC,CDAR UNKNOWNS!-COUNT!-LIST,
  5838. QUOTFAIL!-MOD!-P(POLY!-REMAINING,GETV(FHATVEC,
  5839. CDAR UNKNOWNS!-COUNT!-LIST)));
  5840. GOTO EXIT >>
  5841. ELSE IF W=0 AND ONE!-PREDICTION!-FAILED THEN <<
  5842. PUTV(RESVEC,ONE!-PREDICTION!-FAILED,
  5843. QUOTFAIL!-MOD!-P(POLY!-REMAINING,GETV(FHATVEC,
  5844. ONE!-PREDICTION!-FAILED)));
  5845. GOTO EXIT >>;
  5846. SOLVE!-COUNT:=1;
  5847. IF MAX!-UNKNOWNS THEN
  5848. CORRECTION!-VECTORS:=MAKE!-CORRECTION!-VECTORS(PREDICTED!-FORMS,
  5849. RESVEC,MAX!-UNKNOWNS) >>;
  5850. F1:=MKVECT NUMBER!-OF!-FACTORS;
  5851. K:=1;
  5852. KK:=0;
  5853. CORRECTION!-FACTOR:=GROWTH!-FACTOR;
  5854. IF NOT POLYZEROP RESIDUE THEN FIRST!-TIME:=NIL;
  5855. TEMPLOOP:
  5856. WHILE NOT POLYZEROP RESIDUE AND (NULL MAX!-UNKNOWNS
  5857. OR NULL TEST!-PREDICTION) DO
  5858. IF K>DEGBD THEN RETURN <<
  5859. FACTOR!-TRACE <<
  5860. PRIN2!* "We have overshot the degree bound for ";
  5861. PRINTVAR CAR V >>;
  5862. IF !*OVERSHOOT THEN
  5863. PRINTC "Multivariate degree bound overshoot -> restart";
  5864. BAD!-CASE:=T >>
  5865. ELSE
  5866. IF POLYZEROP(SUBSTRES:=EVALUATE!-MOD!-P(RESIDUE,CAR V,CDR V))
  5867. THEN <<
  5868. K:=IADD1 K;
  5869. RESIDUE:=DIFF!-OVER!-K!-MOD!-P(RESIDUE,K,CAR V);
  5870. CORRECTION!-FACTOR:=
  5871. TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>
  5872. ELSE <<
  5873. FACTOR!-TRACE <<
  5874. PRIN2!* "Hensel Step "; PRINTSTR (KK:=KK #+ 1);
  5875. PRIN2!* "-------------";
  5876. IF KK>10 THEN PRINTSTR "-" ELSE TERPRI!*(T);
  5877. PRIN2!* "Next corrections are for (";
  5878. PRINSF GROWTH!-FACTOR;
  5879. IF NOT (K=1) THEN <<
  5880. PRIN2!* ") ** ";
  5881. PRIN2!* K >> ELSE PRIN2!* '!);
  5882. PRINTSTR ". To find these we solve:";
  5883. PRIN2!* " sum over i [ a(i,1)*fhat(i,0) ] = ";
  5884. PRINSF SUBSTRES;
  5885. PRIN2!* " mod ";
  5886. PRIN2!* HENSEL!-GROWTH!-SIZE;
  5887. PRINTSTR " for a(i,1). ";
  5888. TERPRI!*(NIL)
  5889. >>;
  5890. SOLVE!-FOR!-CORRECTIONS(SUBSTRES,FHAT0S,F0S,F1,CDR VSET);
  5891. % answers in f1;
  5892. IF BAD!-CASE THEN RETURN;
  5893. IF MAX!-UNKNOWNS THEN <<
  5894. SOLVE!-COUNT:=IADD1 SOLVE!-COUNT;
  5895. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5896. PUTV(GETV(CORRECTION!-VECTORS,I),SOLVE!-COUNT,GETV(F1,I));
  5897. IF SOLVE!-COUNT=CAAR UNKNOWNS!-COUNT!-LIST THEN
  5898. TEST!-PREDICTION:=T >>;
  5899. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5900. PUTV(RESVEC,I,PLUS!-MOD!-P(GETV(RESVEC,I),TIMES!-MOD!-P(
  5901. GETV(F1,I),CORRECTION!-FACTOR)));
  5902. FACTOR!-TRACE <<
  5903. PRINTSTR " Giving:";
  5904. PRINTVEC(" a(",NUMBER!-OF!-FACTORS,",1) = ",F1);
  5905. PRINTSTR " New a's are now:";
  5906. PRINTVEC(" a(",NUMBER!-OF!-FACTORS,") = ",RESVEC)
  5907. >>;
  5908. D:=TIMES!-MOD!-P(CORRECTION!-FACTOR,
  5909. FORM!-SUM!-AND!-PRODUCT!-MOD!-P(F1,FHATVEC,
  5910. NUMBER!-OF!-FACTORS));
  5911. IF DEGREE!-IN!-VARIABLE(D,CAR V)>DEGBD THEN RETURN <<
  5912. FACTOR!-TRACE <<
  5913. PRIN2!* "We have overshot the degree bound for ";
  5914. PRINTVAR CAR V >>;
  5915. IF !*OVERSHOOT THEN
  5916. PRINTC "Multivariate degree bound overshoot -> restart";
  5917. BAD!-CASE:=T >>;
  5918. D:=DIFF!-K!-TIMES!-MOD!-P(D,K,CAR V);
  5919. K:=IADD1 K;
  5920. RESIDUE:=DIFF!-OVER!-K!-MOD!-P(
  5921. DIFFERENCE!-MOD!-P(RESIDUE,D),K,CAR V);
  5922. FACTOR!-TRACE <<
  5923. PRIN2!* " and residue = ";
  5924. FAC!-PRINTSF RESIDUE;
  5925. PRINTSTR "-------------"
  5926. >>;
  5927. CORRECTION!-FACTOR:=
  5928. TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>;
  5929. IF NOT POLYZEROP RESIDUE AND NOT BAD!-CASE THEN <<
  5930. IF NULL SOLN!-MATRICES THEN
  5931. SOLN!-MATRICES:=
  5932. CONSTRUCT!-SOLN!-MATRICES(PREDICTED!-FORMS,CDR V);
  5933. FACTOR!-TRACE <<
  5934. PRINTSTR "The Hensel growth so far allows us to test some of";
  5935. PRINTSTR "our predictions:" >>;
  5936. WHILE UNKNOWNS!-COUNT!-LIST AND
  5937. (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=SOLVE!-COUNT DO <<
  5938. UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST;
  5939. FACTOR!-TRACE
  5940. PRINT!-LINEAR!-SYSTEM(CDR W,SOLN!-MATRICES,
  5941. CORRECTION!-VECTORS,PREDICTED!-FORMS,CAR V);
  5942. W:=TRY!-PREDICTION(SOLN!-MATRICES,CORRECTION!-VECTORS,
  5943. PREDICTED!-FORMS,CAR W,CDR W,POLY!-REMAINING,CAR V,FVEC,
  5944. FHATVEC,PREVIOUS!-PREDICTION!-HOLDS);
  5945. IF CAR W='SINGULAR OR CAR W='BAD!-PREDICTION THEN
  5946. IF ONE!-PREDICTION!-FAILED THEN <<
  5947. FACTOR!-TRACE PRINTSTR "Predictions were no help.";
  5948. RETURN MAX!-UNKNOWNS:=NIL >>
  5949. ELSE <<
  5950. IF PREVIOUS!-PREDICTION!-HOLDS THEN <<
  5951. PREDICTIONS:=DELASC(CAR V,PREDICTIONS);
  5952. PREVIOUS!-PREDICTION!-HOLDS:=NIL >>;
  5953. ONE!-PREDICTION!-FAILED:=CDR W >>
  5954. ELSE <<
  5955. PUTV(PREDICTION!-RESULTS,CAR W,CADR W);
  5956. POLY!-REMAINING:=CADDR W >> >>;
  5957. IF NULL MAX!-UNKNOWNS THEN <<
  5958. IF PREVIOUS!-PREDICTION!-HOLDS THEN
  5959. PREDICTIONS:=DELASC(CAR V,PREDICTIONS);
  5960. GOTO TEMPLOOP >>;
  5961. W:=LENGTH UNKNOWNS!-COUNT!-LIST;
  5962. IF W>1 OR (W=1 AND ONE!-PREDICTION!-FAILED) THEN <<
  5963. TEST!-PREDICTION:=NIL;
  5964. GOTO TEMPLOOP >>;
  5965. IF W=1 OR ONE!-PREDICTION!-FAILED THEN <<
  5966. W:=IF ONE!-PREDICTION!-FAILED THEN ONE!-PREDICTION!-FAILED
  5967. ELSE CDAR UNKNOWNS!-COUNT!-LIST;
  5968. PUTV(PREDICTION!-RESULTS,W,QUOTFAIL!-MOD!-P(
  5969. POLY!-REMAINING,GETV(FHATVEC,W))) >>;
  5970. FOR I:=1:NUMBER!-OF!-FACTORS DO
  5971. PUTV(RESVEC,I,GETV(PREDICTION!-RESULTS,I));
  5972. IF NOT PREVIOUS!-PREDICTION!-HOLDS
  5973. AND NOT ONE!-PREDICTION!-FAILED THEN
  5974. PREDICTIONS:=
  5975. (CAR V .
  5976. LIST(SOLN!-MATRICES,PREDICTED!-FORMS,MAX!-UNKNOWNS,
  5977. NUMBER!-OF!-UNKNOWNS))
  5978. . PREDICTIONS >>;
  5979. EXIT:
  5980. FACTOR!-TRACE <<
  5981. IF NOT BAD!-CASE THEN
  5982. IF FIRST!-TIME THEN
  5983. PRINTSTR "But these a's are already correct."
  5984. ELSE <<
  5985. PRINTSTR "Correct a's are:";
  5986. PRINTVEC(" a(",NUMBER!-OF!-FACTORS,") = ",RESVEC)
  5987. >>;
  5988. TERPRI!*(NIL);
  5989. PRINTSTR "**************************************************";
  5990. TERPRI!*(NIL) >>
  5991. END) (FACTOR!-LEVEL+1);
  5992. ENDMODULE;
  5993. MODULE NATURAL;
  5994. % part of resultant program;
  5995. SYMBOLIC PROCEDURE NATURAL!-PRS!-ALGORITHM(A,B,X);
  5996. % A,B are univariate polynomials mod p. The procedure calculates;
  5997. % the natural prs and hence res(A,B) mod p.;
  5998. % one poly may be a number;
  5999. IF NOT (UNIVARIATEP A AND UNIVARIATEP B)
  6000. THEN ERRORF "NON UNIVARIATE POLYS INPUT TO NATURAL PRS ALG"
  6001. ELSE BEGIN
  6002. INTEGER V, TEMPANS, ANS, LOOP;
  6003. SCALAR T1, T2, T3;
  6004. IF NOT X = CAR UNION(VARIABLES!-IN!-FORM A, VARIABLES!-IN!-FORM B)
  6005. THEN ERRORF "WRONG VARIABLE INPUT TO NATURAL";
  6006. LOOP := 0; % loop is used as a pseudo-boolean;
  6007. V := 0;
  6008. TEMPANS := 1;
  6009. T3 := REMAINDER!-MOD!-P(A,B);
  6010. IF (T3 = A)
  6011. THEN <<
  6012. T1 := B;
  6013. T2 := A;
  6014. T3 := REMAINDER!-MOD!-P(T1,T2)
  6015. >>
  6016. ELSE <<
  6017. T1 := A;
  6018. T2 := B
  6019. >>;
  6020. WHILE (LOOP = 0)
  6021. DO <<
  6022. TEMPANS := MODULAR!-TIMES(TEMPANS,
  6023. MODULAR!-EXPT(LC T2,
  6024. LDEG T1 - LEADING!-DEGREE T3));
  6025. V := LOGXOR(V,LOGAND(LDEG T1,LDEG T2,1));
  6026. IF (LEADING!-DEGREE T3 = 0) THEN LOOP := 1
  6027. ELSE BEGIN
  6028. T1 := T2;
  6029. T2 := T3;
  6030. T3 := REMAINDER!-MOD!-P(T1,T2);
  6031. IF NOT (LEADING!-DEGREE T3 < LDEG T2)
  6032. THEN ERRORF "PRS DOES NOT CONVERGE"
  6033. END
  6034. >>;
  6035. ANS := MODULAR!-TIMES(TEMPANS,
  6036. MODULAR!-EXPT(!*D2N T3,LDEG T2));
  6037. RETURN IF V=0 THEN ANS ELSE MODULAR!-MINUS ANS
  6038. END;
  6039. ENDMODULE;
  6040. MODULE PFACTOR;
  6041. % *******************************************************************
  6042. %
  6043. % Copyright (C) University of Cambridge, England 1979
  6044. %
  6045. % *******************************************************************;
  6046. % factorization of polynomials modulo p
  6047. %
  6048. % a. c. norman. 1978.
  6049. %
  6050. %
  6051. %**********************************************************************;
  6052. SYMBOLIC PROCEDURE SIMPPFACTORIZE U;
  6053. % q is a prefix form. convert to standard quotient, factorize,
  6054. % return the factors in the array w. do all work mod p;
  6055. BEGIN
  6056. SCALAR Q,W,P,FF,NN,GCDSAV,BASE!-TIME,LAST!-DISPLAYED!-TIME,
  6057. GC!-BASE!-TIME,LAST!-DISPLAYED!-GC!-TIME,
  6058. USER!-PRIME,CURRENT!-MODULUS,MODULUS!/2;
  6059. IF ATOM U OR ATOM CDR U OR ATOM CDDR U THEN
  6060. REDERR "PFACTORIZE requires 3 arguments";
  6061. Q := CAR U;
  6062. W := CADR U;
  6063. P := CADDR U;
  6064. SET!-TIME();
  6065. GCDSAV := !*GCD;
  6066. !*GCD:=T;
  6067. %gcd explicitly enabled during the following call to simp!*;
  6068. Q:= SIMP!* Q; %convert to standard quotient;
  6069. NN := !*Q2F Q; %must be a polynomial;
  6070. P:=SIMP!* P; %should be a number;
  6071. IF NOT (DENR P=1) THEN REDERR "P HAS A DENOMINATOR IN PFACTOR";
  6072. P:=NUMR P;
  6073. IF NOT NUMBERP P THEN REDERR "P NOT A NUMBER IN PFACTOR";
  6074. IF NOT PRIMEP P THEN REDERR "P NOT PRIME IN PFACTOR";
  6075. USER!-PRIME:=P;
  6076. SET!-MODULUS P;
  6077. !*GCD:=GCDSAV;
  6078. IF DOMAINP NN OR (REDUCE!-MOD!-P LC NN=NIL) THEN
  6079. PRINTC "*** DEGENERATE CASE IN PFACTOR";
  6080. IF NOT (LENGTH VARIABLES!-IN!-FORM NN=1) THEN
  6081. REDERR "MULTIVARIATE INPUT TO PFACTOR";
  6082. NN:=MONIC!-MOD!-P REDUCE!-MOD!-P NN;
  6083. PRINT!-TIME "About to call FACTOR-FORM-MOD-P";
  6084. NN:=ERRORSET('(FACTOR!-FORM!-MOD!-P NN),T,T);
  6085. PRINT!-TIME "FACTOR-FORM-MOD-P returned";
  6086. IF ERRORP NN THEN GO TO FAILED;
  6087. NN:=CAR NN;
  6088. FF:=0; %factor count;
  6089. P:=LIST (0 . 1);
  6090. FOR EACH FFF IN NN DO
  6091. FOR I:=1:CDR FFF DO P:=
  6092. ((FF:=FF+1) . MK!*SQ(CAR FFF ./ 1)) . P;
  6093. RETURN MULTIPLE!-RESULT(P,W);
  6094. FAILED:
  6095. PRINTC "****** FACTORIZATION FAILED******";
  6096. RETURN MULTIPLE!-RESULT(LIST(1 . MK!*SQ Q),W)
  6097. END;
  6098. PUT('PFACTORIZE,'SIMPFN,'SIMPPFACTORIZE);
  6099. SYMBOLIC PROCEDURE FACTOR!-FORM!-MOD!-P P;
  6100. % input:
  6101. % p is a reduce standard form that is to be factorized
  6102. % mod prime;
  6103. % result:
  6104. % ((p1 . x1) (p2 . x2) .. (pn . xn))
  6105. % where p<i> are standard forms and x<i> are integers,
  6106. % and p= product<i> p<i>**x<i>;
  6107. SORT!-FACTORS FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P;
  6108. SYMBOLIC PROCEDURE FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P;
  6109. IF P=1 THEN NIL
  6110. ELSE IF DOMAINP P THEN (P . 1) . NIL
  6111. ELSE
  6112. BEGIN
  6113. SCALAR DP,V;
  6114. V:=(MKSP(MVAR P,1).* 1) .+ NIL;
  6115. DP:=0;
  6116. WHILE EVALUATE!-MOD!-P(P,MVAR V,0)=0 DO <<
  6117. P:=QUOTFAIL!-MOD!-P(P,V);
  6118. DP:=DP+1 >>;
  6119. IF DP>0 THEN RETURN ((V . DP) .
  6120. FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P);
  6121. DP:=DERIVATIVE!-MOD!-P P;
  6122. IF DP=NIL THEN <<
  6123. %here p is a something to the power current!-modulus;
  6124. P:=DIVIDE!-EXPONENTS!-BY!-P(P,CURRENT!-MODULUS);
  6125. P:=FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P;
  6126. RETURN MULTIPLY!-MULTIPLICITIES(P,CURRENT!-MODULUS) >>;
  6127. DP:=GCD!-MOD!-P(P,DP);
  6128. IF DP=1 THEN RETURN FACTORIZE!-PP!-MOD!-P P;
  6129. %now p is not square-free;
  6130. P:=QUOTFAIL!-MOD!-P(P,DP);
  6131. %factorize p and dp separately;
  6132. P:=FACTORIZE!-PP!-MOD!-P P;
  6133. DP:=FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P DP;
  6134. % i feel that this scheme is slightly clumsy, but
  6135. % square-free decomposition mod p is not as straightforward
  6136. % as square free decomposition over the integers, and pfactor
  6137. % is probably not going to be slowed down too badly by
  6138. % this;
  6139. RETURN MERGEFACTORS(P,DP)
  6140. END;
  6141. %**********************************************************************;
  6142. % code to factorize primitive square-free polynomials mod p;
  6143. SYMBOLIC PROCEDURE DIVIDE!-EXPONENTS!-BY!-P(P,N);
  6144. IF ISDOMAIN P THEN P
  6145. ELSE (MKSP(MVAR P,EXACTQUOTIENT(LDEG P,N)) .* LC P) .+
  6146. DIVIDE!-EXPONENTS!-BY!-P(RED P,N);
  6147. SYMBOLIC PROCEDURE EXACTQUOTIENT(A,B);
  6148. BEGIN
  6149. SCALAR W;
  6150. W:=DIVIDE(A,B);
  6151. IF CDR W=0 THEN RETURN CAR W;
  6152. ERROR("INEXACT DIVISION",LIST(A,B,W))
  6153. END;
  6154. SYMBOLIC PROCEDURE MULTIPLY!-MULTIPLICITIES(L,N);
  6155. IF NULL L THEN NIL
  6156. ELSE (CAAR L . (N*CDAR L)) .
  6157. MULTIPLY!-MULTIPLICITIES(CDR L,N);
  6158. SYMBOLIC PROCEDURE MERGEFACTORS(A,B);
  6159. % a and b are lists of factors (with multiplicities),
  6160. % merge them so that no factor occurs more than once in
  6161. % the result;
  6162. IF NULL A THEN B
  6163. ELSE MERGEFACTORS(CDR A,ADDFACTOR(CAR A,B));
  6164. SYMBOLIC PROCEDURE ADDFACTOR(A,B);
  6165. %add factor a into list b;
  6166. IF NULL B THEN LIST A
  6167. ELSE IF CAR A=CAAR B THEN
  6168. (CAR A . (CDR A + CDAR B)) . CDR B
  6169. ELSE CAR B . ADDFACTOR(A,CDR B);
  6170. SYMBOLIC PROCEDURE FACTORIZE!-PP!-MOD!-P P;
  6171. %input a primitive square-free polynomial p,
  6172. % output a list of irreducible factors of p;
  6173. BEGIN
  6174. SCALAR VARS;
  6175. IF P=1 THEN RETURN NIL
  6176. ELSE IF ISDOMAIN P THEN RETURN (P . 1) . NIL;
  6177. % now I am certain that p is not degenerate;
  6178. PRINT!-TIME "primitive square-free case detected";
  6179. VARS:=VARIABLES!-IN!-FORM P;
  6180. IF LENGTH VARS=1 THEN RETURN UNIFAC!-MOD!-P P;
  6181. ERRORF "SHAMBLED IN PFACTOR - MULTIVARIATE CASE RESURFACED"
  6182. END;
  6183. SYMBOLIC PROCEDURE UNIFAC!-MOD!-P P;
  6184. %input p a primitive square-free univariate polynomial
  6185. %output a list of the factors of p over z mod p;
  6186. BEGIN
  6187. SCALAR MODULAR!-INFO,M!-IMAGE!-VARIABLE;
  6188. IF ISDOMAIN P THEN RETURN NIL
  6189. ELSE IF LDEG P=1 THEN RETURN (P . 1) . NIL;
  6190. MODULAR!-INFO:=MKVECT 1;
  6191. M!-IMAGE!-VARIABLE:=MVAR P;
  6192. GET!-FACTOR!-COUNT!-MOD!-P(1,P,USER!-PRIME,NIL);
  6193. PRINT!-TIME "Factor counts obtained";
  6194. GET!-FACTORS!-MOD!-P(1,USER!-PRIME);
  6195. PRINT!-TIME "Actual factors extracted";
  6196. RETURN FOR EACH Z IN GETV(MODULAR!-INFO,1) COLLECT (Z . 1)
  6197. END;
  6198. ENDMODULE;
  6199. MODULE PRES;
  6200. % part of resultant program;
  6201. SYMBOLIC PROCEDURE RESULTANTF(A,B,X);
  6202. % returns resultant of A,B wrt X;
  6203. BEGIN
  6204. SCALAR C, NEW!-A, NEW!-B, NEW!-C, PRIMES!-USED, LOOP!-COUNT,
  6205. ORDER!-CHANGE;
  6206. INTEGER M, N, D, E, Q, F, OLD!-MODULUS, NEW!-PRIME;
  6207. IF (NULL A OR NULL B)
  6208. THEN ERRORF "NIL POLYNOMIAL PASSED TO RESULTANTF";
  6209. IF NOT (MEMBER(X,VARIABLES!-IN!-FORM A)
  6210. AND MEMBER(X,VARIABLES!-IN!-FORM B))
  6211. THEN ERRORF
  6212. "X MUST OCCUR IN BOTH POLYNOMIALS INPUT TO RESULTANTF";
  6213. % X must be in both polynomials if it is to be eliminated
  6214. % between them;
  6215. ORDER!-CHANGE := NIL;
  6216. % pseudo-boolean, indicates whether the order of
  6217. % the variables has been changed;
  6218. % check X is the main variable of A and B, if not make it so;
  6219. IF NOT ((X=MVAR A) AND (X=MVAR B))
  6220. THEN BEGIN
  6221. SCALAR V;
  6222. V := SETKORDER APPEND(CONS(X,NIL),
  6223. DELETE(X,UNION(VARIABLES!-IN!-FORM A,
  6224. VARIABLES!-IN!-FORM B)));
  6225. A := REORDER A;
  6226. B := REORDER B;
  6227. ORDER!-CHANGE := LIST V
  6228. END;
  6229. % initialise variables ;
  6230. OLD!-MODULUS := SET!-MODULUS NIL;
  6231. M := LDEG A;
  6232. N := LDEG B;
  6233. D := MAX!-NORM!-COEFFS(A,X);
  6234. E := MAX!-NORM!-COEFFS(B,X);
  6235. Q := 1;
  6236. C := 0;
  6237. PRIMES!-USED := NIL; % list of primes used - dont want repetitions;
  6238. NEW!-A := 0;
  6239. NEW!-B := 0;
  6240. F := 2 * FACTORIAL(M+N) * D**N * E**M;
  6241. % F/2 is the limit of the coefficients of the resultant of A,B ;
  6242. % main loop starts here;
  6243. WHILE NOT (Q > F)
  6244. DO BEGIN
  6245. LOOP!-COUNT := T; % used as a pseudo-boolean;
  6246. WHILE ((DEGREE!-IN!-VARIABLE(NEW!-A,X) < M)
  6247. OR (DEGREE!-IN!-VARIABLE(NEW!-B,X) < N)
  6248. OR LOOP!-COUNT )
  6249. DO BEGIN
  6250. LOOP!-COUNT := NIL;
  6251. % set up prime modulus before calling cpres ;
  6252. NEW!-PRIME := RANDOM!-PRIME();
  6253. WHILE MEMBER(NEW!-PRIME,PRIMES!-USED) DO
  6254. NEW!-PRIME := RANDOM!-PRIME();
  6255. PRIMES!-USED := NEW!-PRIME . PRIMES!-USED;
  6256. SET!-MODULUS NEW!-PRIME;
  6257. NEW!-A := REDUCE!-MOD!-P A;
  6258. NEW!-B := REDUCE!-MOD!-P B
  6259. END;
  6260. NEW!-C := CPRES(NEW!-A,NEW!-B,X);
  6261. C := CHINESE!-REMAINDER(C,NEW!-C,Q,NEW!-PRIME);
  6262. Q := Q * NEW!-PRIME;
  6263. IF 2* GET!-HEIGHT C > F THEN ERRORF "COEFFICIENT BOUND EXCEEDED"
  6264. END;
  6265. IF ORDER!-CHANGE
  6266. THEN BEGIN
  6267. SETKORDER CAR ORDER!-CHANGE;
  6268. C := REORDER C
  6269. END;
  6270. SET!-MODULUS OLD!-MODULUS; %return to original state before exiting;
  6271. RETURN C
  6272. END;
  6273. SYMBOLIC PROCEDURE MAX!-NORM!-COEFFS(A,VAR);
  6274. % var must be the main variable of A;
  6275. IF ISDOMAIN A THEN ABS !*D2N A
  6276. ELSE IF NOT MVAR A = VAR THEN SUM!-OF!-NORMS A
  6277. ELSE MAX(SUM!-OF!-NORMS LC A,MAX!-NORM!-COEFFS(RED A,VAR));
  6278. SYMBOLIC PROCEDURE SUM!-OF!-NORMS A;
  6279. IF ISDOMAIN A THEN ABS !*D2N A
  6280. ELSE PLUS(SUM!-OF!-NORMS LC A,SUM!-OF!-NORMS RED A);
  6281. SYMBOLIC PROCEDURE CHINESE!-REMAINDER(POLY!-B,POLY!-A,Q,P);
  6282. % poly!-b is a poly with !coeffs! < Q/2 ;
  6283. % poly!-a is a poly mod p ;
  6284. % returns a poly with !coeffs! < PQ/2 ;
  6285. IF ISDOMAIN POLY!-A
  6286. THEN IF ISDOMAIN POLY!-B
  6287. THEN GARNERS!-ALG(!*D2N POLY!-B,!*D2N POLY!-A,Q,P)
  6288. ELSE ADJOIN!-TERM(LPOW POLY!-B,
  6289. CHINESE!-REMAINDER(LC POLY!-B,0,Q,P),
  6290. CHINESE!-REMAINDER(RED POLY!-B,POLY!-A,Q,P))
  6291. ELSE IF ISDOMAIN POLY!-B
  6292. THEN ADJOIN!-TERM(LPOW POLY!-A,
  6293. CHINESE!-REMAINDER(0,LC POLY!-A,Q,P),
  6294. CHINESE!-REMAINDER(POLY!-B,RED POLY!-A,Q,P))
  6295. ELSE IF LPOW POLY!-A = LPOW POLY!-B
  6296. THEN ADJOIN!-TERM(LPOW POLY!-A,
  6297. CHINESE!-REMAINDER(LC POLY!-B,LC POLY!-A,Q,P),
  6298. CHINESE!-REMAINDER(RED POLY!-B,RED POLY!-A,Q,P))
  6299. ELSE IF COMES!-BEFORE(LPOW POLY!-A,LPOW POLY!-B)
  6300. THEN ADJOIN!-TERM(LPOW POLY!-A,
  6301. CHINESE!-REMAINDER(0,LC POLY!-A,Q,P),
  6302. CHINESE!-REMAINDER(POLY!-B,RED POLY!-A,Q,P))
  6303. ELSE ADJOIN!-TERM(LPOW POLY!-B,
  6304. CHINESE!-REMAINDER(LC POLY!-B,0,Q,P),
  6305. CHINESE!-REMAINDER(RED POLY!-B,POLY!-A,Q,P));
  6306. SYMBOLIC PROCEDURE GARNERS!-ALG(B,A,Q,P);
  6307. % inputs !B! < Q/2, A mod P ;
  6308. % returns unique integer c such that c = B mod Q and c = A modP;
  6309. % and !c! < PQ/2 ;
  6310. BEGIN
  6311. INTEGER L;
  6312. L := MODULAR!-QUOTIENT(MODULAR!-DIFFERENCE(A,MODULAR!-NUMBER B),
  6313. MODULAR!-NUMBER Q);
  6314. IF L*2 > P THEN L := DIFFERENCE(L,P);
  6315. % PRINTC "L IS";
  6316. % SUPERPRINT L;
  6317. RETURN !*NUM2F PLUS(B,TIMES(L,Q))
  6318. END;
  6319. SYMBOLIC PROCEDURE LEADING!-DEGREE A;
  6320. % returns 0 if a is numeric, ldeg a otherwise;
  6321. IF ISDOMAIN A THEN 0
  6322. ELSE LDEG A;
  6323. SYMBOLIC PROCEDURE FACTORIAL N;
  6324. IF NOT ISDOMAIN N THEN ERRORF "NUMBER EXPECTED IN FACTORIAL"
  6325. ELSE IF N < 0 THEN ERRORF "NEGATIVE NUMBER GIVEN TO FACTORIAL"
  6326. ELSE IF N = 0 THEN 1
  6327. ELSE N * FACTORIAL(N-1);
  6328. ENDMODULE;
  6329. MODULE RSLTNT;
  6330. % (C) Copyright 1979, University of Cambridge;
  6331. % RESULTANT CALCULATION;
  6332. SYMBOLIC PROCEDURE SIMPRESULTANT U;
  6333. % COMPUTE THE RESULTANT OF A AND B WITH RESPECT TO
  6334. % THE VARIABLE 'VAR';
  6335. BEGIN
  6336. SCALAR A,B,VAR;
  6337. IF ATOM U OR ATOM CDR U OR ATOM CDDR U THEN
  6338. REDERR "RESULTANT requires 3 arguments";
  6339. A:= !*Q2F SIMP!* CAR U; %must be polynomials;
  6340. B:= !*Q2F SIMP!* CADR U;
  6341. VAR:= !*Q2K SIMP!* CADDR U;
  6342. % PRINTC "LISP DATASTRUCTURES THAT ARE ARGS FOR RESULTANT";
  6343. % SUPERPRINT A;
  6344. % SUPERPRINT B;
  6345. % SUPERPRINT VAR;
  6346. A := RESULTANTF(A,B,VAR);
  6347. RETURN (A ./ 1);
  6348. END;
  6349. PUT('RESULTANT,'SIMPFN,'SIMPRESULTANT);
  6350. ENDMODULE;
  6351. MODULE UNIHENS;
  6352. % *******************************************************************
  6353. %
  6354. % copyright (c) university of cambridge, england 1981
  6355. %
  6356. % *******************************************************************;
  6357. % new hensel construction and related code ;
  6358. % - univariate case with quadratic growth;
  6359. %
  6360. % p. m. a. moore. 1979.
  6361. %
  6362. %
  6363. %**********************************************************************;
  6364. SYMBOLIC PROCEDURE UHENSEL!.EXTEND(POLY,BEST!-FLIST,LCLIST,P);
  6365. % extend poly=product(factors in best!-flist) mod p
  6366. % even if poly is non-monic. return a list (ok. list of factors) if
  6367. % factors can be extended to be correct over the integers,
  6368. % otherwise return a list (failed <reason> <reason>);
  6369. BEGIN SCALAR W,K,TIMER,OLD!-MODULUS,ALPHAVEC,MODULAR!-FLIST,FACTORVEC,
  6370. MODFVEC,COEFFTBD,FCOUNT,FHATVEC,DELTAM,MOD!-SYMM!-FLIST,
  6371. CURRENT!-FACTOR!-PRODUCT,FACVEC,FACTORS!-DONE,HENSEL!-POLY;
  6372. PRIME!-BASE:=P;
  6373. OLD!-MODULUS:=SET!-MODULUS P;
  6374. TIMER:=READTIME();
  6375. NUMBER!-OF!-FACTORS:=LENGTH BEST!-FLIST;
  6376. W:=EXPT(LC POLY,NUMBER!-OF!-FACTORS -1);
  6377. IF LC POLY < 0 THEN ERRORF LIST("LC SHOULD NOT BE -VE",POLY);
  6378. COEFFTBD:=MAX(110,LC POLY*GET!-COEFFT!-BOUND(POLY,LDEG POLY));
  6379. POLY:=MULTF(POLY,W);
  6380. MODULAR!-FLIST:=FOR EACH FF IN BEST!-FLIST COLLECT
  6381. REDUCE!-MOD!-P FF;
  6382. % modular factors have been multiplied by a constant to
  6383. % fix the l.c.'s, so they may be out of range - this
  6384. % fixes that;
  6385. IF NOT(W=1) THEN FACTOR!-TRACE <<
  6386. PRIN2!* "Altered univariate polynomial: "; FAC!-PRINTSF POLY >>;
  6387. % make sure the leading coefft will not cause trouble
  6388. % in the hensel construction;
  6389. MOD!-SYMM!-FLIST:=FOR EACH FF IN MODULAR!-FLIST COLLECT
  6390. MAKE!-MODULAR!-SYMMETRIC FF;
  6391. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6392. PRIN2!* "The factors mod "; PRIN2!* P;
  6393. PRINTSTR " to start from are:";
  6394. FCOUNT:=1;
  6395. FOR EACH FF IN MOD!-SYMM!-FLIST DO <<
  6396. PRIN2!* " f("; PRIN2!* FCOUNT; PRIN2!* ")=";
  6397. FAC!-PRINTSF FF; FCOUNT:=IADD1 FCOUNT >>;
  6398. TERPRI!*(NIL) >>;
  6399. ALPHALIST:=ALPHAS(NUMBER!-OF!-FACTORS,MODULAR!-FLIST,1);
  6400. % 'magic' polynomials associated with the image factors;
  6401. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6402. PRINTSTR
  6403. "The following modular polynomials are chosen such that:";
  6404. TERPRI();
  6405. PRIN2!* " a(1)*h(1) + ... + a(";
  6406. PRIN2!* NUMBER!-OF!-FACTORS;
  6407. PRIN2!* ")*h("; PRIN2!* NUMBER!-OF!-FACTORS;
  6408. PRIN2!* ") = 1 mod "; PRINTSTR P;
  6409. TERPRI();
  6410. PRINTSTR " where h(i)=(product of all f(j) [see below])/f(i)";
  6411. PRINTSTR " and degree of a(i) < degree of f(i).";
  6412. FCOUNT:=1;
  6413. FOR EACH A IN MODULAR!-FLIST DO <<
  6414. PRIN2!* " a("; PRIN2!* FCOUNT; PRIN2!* ")=";
  6415. FAC!-PRINTSF CDR GET!-ALPHA A;
  6416. PRIN2!* " f("; PRIN2!* FCOUNT; PRIN2!* ")=";
  6417. FAC!-PRINTSF A;
  6418. FCOUNT:=IADD1 FCOUNT >>
  6419. >>;
  6420. K:=0;
  6421. FACTORVEC:=MKVECT NUMBER!-OF!-FACTORS;
  6422. MODFVEC:=MKVECT NUMBER!-OF!-FACTORS;
  6423. ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS;
  6424. FOR EACH MODSYMMF IN MOD!-SYMM!-FLIST DO
  6425. << PUTV(FACTORVEC,K:=K+1,FORCE!-LC(MODSYMMF,CAR LCLIST));
  6426. LCLIST:=CDR LCLIST
  6427. >>;
  6428. K:=0;
  6429. FOR EACH MODFACTOR IN MODULAR!-FLIST DO
  6430. << PUTV(MODFVEC,K:=K+1,MODFACTOR);
  6431. PUTV(ALPHAVEC,K,CDR GET!-ALPHA MODFACTOR);
  6432. >>;
  6433. % best!-fvec is now a vector of factors of poly correct
  6434. % mod p with true l.c.s forced in ;
  6435. FHATVEC:=MKVECT NUMBER!-OF!-FACTORS;
  6436. W:=HENSEL!-MOD!-P(POLY,MODFVEC,FACTORVEC,COEFFTBD,NIL,P);
  6437. IF CAR W='OVERSHOT THEN
  6438. BEGIN SCALAR OKLIST,BADLIST,M,R,FF,OM,POL;
  6439. M:=CADR W; % the modulus;
  6440. R:=GETV(FACTORVEC,0); % the no: of factors;
  6441. IF R=2 THEN RETURN (IRREDUCIBLE:=T);
  6442. IF FACTORS!-DONE THEN <<
  6443. POLY:=HENSEL!-POLY;
  6444. FOR EACH WW IN FACTORS!-DONE DO
  6445. POLY:=MULTF(POLY,WW) >>;
  6446. POL:=POLY;
  6447. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  6448. ALPHALIST:=NIL;
  6449. FOR I:=R STEP -1 UNTIL 1 DO
  6450. ALPHALIST:=
  6451. (REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I))
  6452. . ALPHALIST;
  6453. SET!-MODULUS OM;
  6454. % bring alphalist up to date;
  6455. FOR I:=1:R DO <<
  6456. FF:=GETV(FACTORVEC,I);
  6457. IF NOT DIDNTGO(W:=QUOTF(POL,FF)) THEN
  6458. << OKLIST:=FF . OKLIST; POL:=W>>
  6459. ELSE BADLIST:=(I . FF) . BADLIST >>;
  6460. IF NULL BADLIST THEN W:='OK . OKLIST
  6461. ELSE <<
  6462. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6463. PRINTSTR "Overshot factors are:";
  6464. FOR EACH F IN BADLIST DO <<
  6465. PRIN2!* " f("; PRIN2!* CAR F; PRIN2!* ")=";
  6466. FAC!-PRINTSF CDR F >>
  6467. >>;
  6468. W:=TRY!.COMBINING(BADLIST,POL,M,NIL);
  6469. IF CAR W='ONE! BAD! FACTOR THEN BEGIN SCALAR X;
  6470. W:=APPEND(OKLIST,CDR W);
  6471. X:=1;
  6472. FOR EACH V IN W DO X:=MULTF(X,V);
  6473. W:='OK . (QUOTFAIL(POL,X) . W)
  6474. END
  6475. ELSE W:='OK . APPEND(OKLIST,W) >>;
  6476. IF (NOT !*LINEAR) AND MULTIVARIATE!-INPUT!-POLY THEN <<
  6477. POLY:=1;
  6478. NUMBER!-OF!-FACTORS:=0;
  6479. FOR EACH FACC IN CDR W DO <<
  6480. POLY:=MULTF(POLY,FACC);
  6481. NUMBER!-OF!-FACTORS:=1 #+ NUMBER!-OF!-FACTORS >>;
  6482. % make sure poly is the product of the factors we have,
  6483. % we recalculate it this way because we may have the wrong
  6484. % lc in old value of poly;
  6485. RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,CDR W,
  6486. NUMBER!-OF!-FACTORS);
  6487. IF M=DELTAM THEN ERRORF LIST("Coefft bound < prime ?",
  6488. COEFFTBD,M);
  6489. M:=DELTAM*DELTAM;
  6490. WHILE M<LARGEST!-SMALL!-MODULUS DO <<
  6491. QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS);
  6492. M:=M*DELTAM >>;
  6493. HENSEL!-GROWTH!-SIZE:=DELTAM;
  6494. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  6495. ALPHALIST:=NIL;
  6496. FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO
  6497. ALPHALIST:=
  6498. (REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I))
  6499. . ALPHALIST;
  6500. SET!-MODULUS OM >>
  6501. END
  6502. ELSE BEGIN SCALAR R,FACLIST,OM;
  6503. R:=GETV(FACTORVEC,0); % no of factors;
  6504. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  6505. ALPHALIST:=NIL;
  6506. FOR I:=R STEP -1 UNTIL 1 DO
  6507. ALPHALIST:=(REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I))
  6508. . ALPHALIST;
  6509. SET!-MODULUS OM;
  6510. % bring alphalist up to date;
  6511. FOR I:=R STEP -1 UNTIL 1 DO
  6512. FACLIST:=GETV(FACTORVEC,I) . FACLIST;
  6513. W:=CAR W . FACLIST
  6514. END;
  6515. SET!-MODULUS OLD!-MODULUS;
  6516. FACTOR!-TRACE BEGIN SCALAR K;
  6517. K:=0;
  6518. PRINTSTR "Univariate factors, possibly with adjusted leading";
  6519. PRINTSTR "coefficients, are:";
  6520. FOR EACH WW IN CDR W DO <<
  6521. PRIN2!* " f("; PRIN2!* (K:=K #+ 1);
  6522. PRIN2!* ")="; FAC!-PRINTSF WW >>
  6523. END;
  6524. RETURN IF IRREDUCIBLE THEN T ELSE IF NON!-MONIC THEN
  6525. (CAR W . PRIMITIVE!.PARTS(CDR W,M!-IMAGE!-VARIABLE,T))
  6526. ELSE W
  6527. END;
  6528. SYMBOLIC PROCEDURE GET!-COEFFT!-BOUND(POLY,DDEG);
  6529. % this uses Mignottes bound which is minimal I believe;
  6530. % NB. poly had better be univariate as bound only valid for this;
  6531. BINOMIAL!-COEFFT(DDEG/2,DDEG/4) * ROOT!-SQUARES(POLY,0);
  6532. SYMBOLIC PROCEDURE BINOMIAL!-COEFFT(N,R);
  6533. IF N<R THEN NIL
  6534. ELSE IF N=R THEN 1
  6535. ELSE IF R=1 THEN N
  6536. ELSE BEGIN SCALAR N!-C!-R,B;
  6537. N!-C!-R:=1;
  6538. B:=MIN(R,N-R);
  6539. FOR I:=1:B DO
  6540. N!-C!-R:=(N!-C!-R * (N - I + 1)) / I;
  6541. RETURN N!-C!-R
  6542. END;
  6543. SYMBOLIC PROCEDURE PMAM!-SQRT N;
  6544. % find the square root of n and return integer part + 1;
  6545. % n is fixed pt on input as it may be very large ie > largest
  6546. % allowed floating pt number so i scale it appropriately;
  6547. BEGIN SCALAR S,TEN!*!*14,TEN!*!*12;
  6548. S:=0;
  6549. TEN!*!*12:=10**12;
  6550. TEN!*!*14:=100*TEN!*!*12;
  6551. WHILE N>TEN!*!*14 DO << S:=IADD1 S; N:=1+N/TEN!*!*12 >>;
  6552. RETURN ((FIX SQRT FLOAT N) + 1) * 10**(6*S)
  6553. END;
  6554. SYMBOLIC PROCEDURE FIND!-ALPHAS!-IN!-A!-RING(N,MFLIST,FHATLIST,GAMMA);
  6555. % find the alphas (as below) given that the modulus may not be prime
  6556. % but is a prime power.;
  6557. BEGIN SCALAR GG,M,PPOW,I,GG!-MOD!-P,MODFLIST,WVEC,ALPHA,ALPHAZEROS,W;
  6558. IF NULL PRIME!-BASE THEN ERRORF
  6559. LIST("Prime base not set for finding alphas",
  6560. CURRENT!-MODULUS,N,MFLIST);
  6561. M:=SET!-MODULUS PRIME!-BASE;
  6562. MODFLIST:= IF M=PRIME!-BASE THEN MFLIST
  6563. ELSE FOR EACH FTHING IN MFLIST COLLECT
  6564. REDUCE!-MOD!-P !*MOD2F FTHING;
  6565. ALPHALIST:=ALPHAS(N,MODFLIST,GAMMA);
  6566. IF M=PRIME!-BASE THEN <<
  6567. SET!-MODULUS M;
  6568. RETURN ALPHALIST >>;
  6569. I:=0;
  6570. ALPHAZEROS:=MKVECT N;
  6571. WVEC:=MKVECT N;
  6572. FOR EACH MODFTHING IN MODFLIST DO <<
  6573. PUTV(MODFVEC,I:=IADD1 I,MODFTHING);
  6574. PUTV(ALPHAVEC,I,!*F2MOD(ALPHA:=CDR GET!-ALPHA MODFTHING));
  6575. PUTV(ALPHAZEROS,I,ALPHA);
  6576. PUTV(WVEC,I,ALPHA);
  6577. PUTV(FHATVEC,I,CAR FHATLIST);
  6578. FHATLIST:=CDR FHATLIST >>;
  6579. GG:=GAMMA;
  6580. PPOW:=PRIME!-BASE;
  6581. WHILE PPOW<M DO <<
  6582. SET!-MODULUS M;
  6583. GG:=!*F2MOD QUOTFAIL(!*MOD2F DIFFERENCE!-MOD!-P(GG,
  6584. FORM!-SUM!-AND!-PRODUCT!-MOD!-M(WVEC,FHATVEC,N)),PRIME!-BASE);
  6585. SET!-MODULUS PRIME!-BASE;
  6586. GG!-MOD!-P:=REDUCE!-MOD!-P !*MOD2F GG;
  6587. FOR K:=1:N DO <<
  6588. PUTV(WVEC,K,W:=REMAINDER!-MOD!-P(
  6589. TIMES!-MOD!-P(GETV(ALPHAZEROS,K),GG!-MOD!-P),
  6590. GETV(MODFVEC,K)));
  6591. PUTV(ALPHAVEC,K,ADDF(GETV(ALPHAVEC,K),MULTF(!*MOD2F W,PPOW)))>>;
  6592. PPOW:=PPOW*PRIME!-BASE >>;
  6593. SET!-MODULUS M;
  6594. I:=0;
  6595. RETURN (FOR EACH FTHING IN MFLIST COLLECT
  6596. (FTHING . !*F2MOD GETV(ALPHAVEC,I:=IADD1 I)))
  6597. END;
  6598. SYMBOLIC PROCEDURE ALPHAS(N,FLIST,GAMMA);
  6599. % finds alpha,beta,delta,... wrt factors f(i) in flist s.t:
  6600. % alpha*g(1) + beta*g(2) + delta*g(3) + ... = gamma mod p;
  6601. % where g(i)=product(all the f(j) except f(i) itself);
  6602. % (cf. xgcd!-mod!-p below). n is number of factors in flist;
  6603. IF N=1 THEN LIST(CAR FLIST . GAMMA)
  6604. ELSE BEGIN SCALAR K,W,F1,F2,I,GAMMA1,GAMMA2;
  6605. K:=N/2;
  6606. F1:=1; F2:=1;
  6607. I:=1;
  6608. FOR EACH F IN FLIST DO
  6609. << IF I>K THEN F2:=TIMES!-MOD!-P(F,F2)
  6610. ELSE F1:=TIMES!-MOD!-P(F,F1);
  6611. I:=I+1 >>;
  6612. W:=XGCD!-MOD!-P(F1,F2,1,POLYZERO,POLYZERO,1);
  6613. IF ATOM W THEN
  6614. RETURN 'FACTORS! NOT! COPRIME;
  6615. GAMMA1:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(CDR W,GAMMA),F1);
  6616. GAMMA2:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(CAR W,GAMMA),F2);
  6617. I:=1; F1:=NIL; F2:=NIL;
  6618. FOR EACH F IN FLIST DO
  6619. << IF I>K THEN F2:=F . F2
  6620. ELSE F1:=F . F1;
  6621. I:=I+1 >>;
  6622. RETURN APPEND(
  6623. ALPHAS(K,F1,GAMMA1),
  6624. ALPHAS(N-K,F2,GAMMA2))
  6625. END;
  6626. SYMBOLIC PROCEDURE XGCD!-MOD!-P(A,B,X1,Y1,X2,Y2);
  6627. % finds alpha and beta s.t. alpha*a+beta*b=1;
  6628. % returns alpha . beta or nil if a and b are not coprime;
  6629. IF NULL B THEN NIL
  6630. ELSE IF ISDOMAIN B THEN BEGIN
  6631. B:=MODULAR!-RECIPROCAL B;
  6632. X2:=MULTIPLY!-BY!-CONSTANT!-MOD!-P(X2,B);
  6633. Y2:=MULTIPLY!-BY!-CONSTANT!-MOD!-P(Y2,B);
  6634. RETURN X2 . Y2 END
  6635. ELSE BEGIN SCALAR Q;
  6636. Q:=QUOTIENT!-MOD!-P(A,B); % Truncated quotient here;
  6637. RETURN XGCD!-MOD!-P(B,DIFFERENCE!-MOD!-P(A,TIMES!-MOD!-P(B,Q)),
  6638. X2,Y2,
  6639. DIFFERENCE!-MOD!-P(X1,TIMES!-MOD!-P(X2,Q)),
  6640. DIFFERENCE!-MOD!-P(Y1,TIMES!-MOD!-P(Y2,Q)))
  6641. END;
  6642. SYMBOLIC PROCEDURE HENSEL!-MOD!-P(POLY,MVEC,FVEC,CBD,VSET,P);
  6643. % hensel construction building up in powers of p;
  6644. % given that poly=product(factors in factorvec) mod p, find the full
  6645. % factors over the integers. mvec contains the univariate factors mod p
  6646. % while fvec contains our best knowledge of the factors to date.
  6647. % fvec includes leading coeffts (and in multivariate case possibly other
  6648. % coeffts) of the factors. return a list whose first element is a flag
  6649. % with one of the following values:
  6650. % ok construction worked, the cdr of the result is a list of
  6651. % the correct factors.;
  6652. % failed inputs must have been incorrect
  6653. % overshot factors are correct mod some power of p (say p**m),
  6654. % but are not correct over the integers.
  6655. % result is (overshot,p**m,list of factors so far);
  6656. BEGIN SCALAR W,U0,DELFVEC,OLD!.MOD,RES,M;
  6657. U0:=INITIALIZE!-HENSEL(NUMBER!-OF!-FACTORS,P,POLY,MVEC,FVEC,CBD);
  6658. % u0 contains the product (over integers) of factors mod p;
  6659. IF NUMBER!-OF!-FACTORS=1 THEN GOTO EXIT;
  6660. % only one factor to grow! but need to go this deep to
  6661. % construct the alphas and set things up for the
  6662. % multivariate growth which may follow;
  6663. FACTOR!-TRACE <<
  6664. PRINTSTR
  6665. "We are now ready to use the Hensel construction to grow";
  6666. PRIN2!* "in powers of "; PRINTSTR CURRENT!-MODULUS;
  6667. IF NOT !*OVERVIEW THEN <<PRIN2!* "Polynomial to factor (=U): ";
  6668. FAC!-PRINTSF HENSEL!-POLY>>;
  6669. PRIN2!* "Initial factors mod "; PRIN2!* P;
  6670. PRINTSTR " with some correct coefficients:";
  6671. W:=1;
  6672. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  6673. PRIN2!* " f("; PRIN2!* W; PRIN2!* ")=";
  6674. FAC!-PRINTSF GETV(FACTORVEC,I); W:=IADD1 W >>;
  6675. IF NOT !*OVERVIEW THEN << PRIN2!* "Coefficient bound = ";
  6676. PRIN2!* COEFFTBD;
  6677. TERPRI!*(NIL);
  6678. PRIN2!* "The product of factors over the integers is ";
  6679. FAC!-PRINTSF U0;
  6680. PRINTSTR "In each step below, the residue is U - (product of the";
  6681. PRINTSTR
  6682. "factors as far as we know them). The correction to each";
  6683. PRINTSTR "factor, f(i), is (a(i)*v) mod f0(i) where f0(i) is";
  6684. PRIN2!* "f(i) mod "; PRIN2!* P;
  6685. PRINTSTR "(ie. the f(i) used in calculating the a(i))"
  6686. >>
  6687. >>;
  6688. OLD!.MOD:=SET!-MODULUS P;
  6689. RES:=ADDF(HENSEL!-POLY,NEGF U0);
  6690. % calculate the residue. from now on this is always
  6691. % kept in res;
  6692. M:=P;
  6693. % measure of how far we have built up factors - at this;
  6694. % stage we know the constant terms mod p in the factors;
  6695. WHILE NOT POLYZEROP RES DO
  6696. <<
  6697. IF (M/2)>COEFFTBD THEN
  6698. RETURN <<
  6699. % we started with a false split of the image so some
  6700. % of the factors we have built up must amalgamate in
  6701. % the complete factorization;
  6702. IF !*OVERSHOOT THEN <<
  6703. PRINC IF NULL VSET THEN "Univariate " ELSE "Multivariate ";
  6704. PRINTC "coefft bound overshoot" >>;
  6705. IF NOT !*OVERVIEW THEN
  6706. FACTOR!-TRACE PRINTSTR "We have overshot the coefficient bound";
  6707. W:='OVERSHOT >>;
  6708. RES:=QUOTFAIL(RES,DELTAM);
  6709. % next term in residue;
  6710. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6711. PRIN2!* "Residue divided by "; PRIN2!* M; PRIN2!* " is ";
  6712. FAC!-PRINTSF RES >>;
  6713. IF (NOT !*LINEAR) AND NULL VSET
  6714. AND M<=LARGEST!-SMALL!-MODULUS AND M>P THEN
  6715. QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS);
  6716. W:=REDUCE!-MOD!-P RES;
  6717. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6718. PRIN2!* "Next term in residue to kill is:";
  6719. PRINSF W; PRIN2!* " which is of size ";
  6720. FAC!-PRINTSF (DELTAM*M);
  6721. >>;
  6722. SOLVE!-FOR!-CORRECTIONS(W,FHATVEC,MODFVEC,DELFVEC,VSET);
  6723. % delfvec is vector of next correction terms to factors;
  6724. MAKE!-VEC!-MODULAR!-SYMMETRIC(DELFVEC,NUMBER!-OF!-FACTORS);
  6725. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6726. PRINTSTR "Correction terms are:";
  6727. W:=1;
  6728. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  6729. PRIN2!* " To f("; PRIN2!* W; PRIN2!* "): ";
  6730. FAC!-PRINTSF MULTF(M,GETV(DELFVEC,I));
  6731. W:=IADD1 W >>
  6732. >>;
  6733. W:=TERMS!-DONE(FACTORVEC,DELFVEC,M);
  6734. RES:=ADDF(RES,NEGF W);
  6735. % subtract out the terms generated by these corrections
  6736. % from the residue;
  6737. CURRENT!-FACTOR!-PRODUCT:=
  6738. ADDF(CURRENT!-FACTOR!-PRODUCT,MULTF(M,W));
  6739. % add in the correction terms to give new factor product;
  6740. FOR I:=1:NUMBER!-OF!-FACTORS DO
  6741. PUTV(FACTORVEC,I,
  6742. ADDF(GETV(FACTORVEC,I),MULTF(GETV(DELFVEC,I),M)));
  6743. % add the corrections into the factors;
  6744. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6745. PRINTSTR " giving new factors as:";
  6746. W:=1;
  6747. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  6748. PRIN2!* " f("; PRIN2!* W; PRIN2!* ")=";
  6749. FAC!-PRINTSF GETV(FACTORVEC,I); W:=IADD1 W >>
  6750. >>;
  6751. M:=M*DELTAM;
  6752. IF NOT POLYZEROP RES AND NULL VSET AND
  6753. NOT RECONSTRUCTING!-GCD THEN
  6754. BEGIN SCALAR J,U,FAC;
  6755. J:=0;
  6756. WHILE (J:=J #+ 1)<=NUMBER!-OF!-FACTORS DO
  6757. % IF NULL GETV(DELFVEC,J) AND;
  6758. % - Try dividing out every time for now;
  6759. IF NOT DIDNTGO
  6760. (U:=QUOTF(HENSEL!-POLY,FAC:=GETV(FACTORVEC,J))) THEN <<
  6761. HENSEL!-POLY:=U;
  6762. RES:=ADJUST!-GROWTH(FAC,J,M);
  6763. J:=NUMBER!-OF!-FACTORS >>
  6764. END
  6765. >>;
  6766. EXIT:
  6767. IF FACTORS!-DONE THEN <<
  6768. IF NOT(W='OVERSHOT) THEN M:=P*P;
  6769. SET!-HENSEL!-FLUIDS!-BACK P >>;
  6770. IF (NOT (W='OVERSHOT)) AND NULL VSET
  6771. AND (NOT !*LINEAR) AND MULTIVARIATE!-INPUT!-POLY THEN
  6772. WHILE M<LARGEST!-SMALL!-MODULUS DO <<
  6773. IF NOT(M=DELTAM) THEN QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS);
  6774. M:=M*DELTAM >>;
  6775. % set up the alphas etc so that multivariate growth can
  6776. % use a hensel growth size of about word size;
  6777. SET!-MODULUS OLD!.MOD;
  6778. % reset the old modulus;
  6779. HENSEL!-GROWTH!-SIZE:=DELTAM;
  6780. PUTV(FACTORVEC,0,NUMBER!-OF!-FACTORS);
  6781. RETURN
  6782. IF W='OVERSHOT THEN LIST('OVERSHOT,M,FACTORVEC)
  6783. ELSE 'OK . FACTORVEC
  6784. END;
  6785. SYMBOLIC PROCEDURE INITIALIZE!-HENSEL(R,P,POLY,MVEC,FVEC,CBD);
  6786. % set up the vectors and initialize the fluids;
  6787. BEGIN SCALAR U0,W;
  6788. DELFVEC:=MKVECT R;
  6789. FACVEC:=MKVECT R;
  6790. HENSEL!-POLY:=POLY;
  6791. MODFVEC:=MVEC;
  6792. FACTORVEC:=FVEC;
  6793. COEFFTBD:=CBD;
  6794. FACTORS!-DONE:=NIL;
  6795. DELTAM:=P;
  6796. U0:=1;
  6797. FOR I:=1:R DO U0:=MULTF(GETV(FACTORVEC,I),U0);
  6798. CURRENT!-FACTOR!-PRODUCT:=U0;
  6799. RETURN U0
  6800. END;
  6801. % SYMBOLIC PROCEDURE RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,FACLIST,N);
  6802. % BEGIN SCALAR I,OM,MODF;
  6803. % CURRENT!-FACTOR!-PRODUCT:=POLY;
  6804. % OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  6805. % I:=0;
  6806. % FOR EACH FAC IN FACLIST DO <<
  6807. % PUTV(FACTORVEC,I:=IADD1 I,FAC);
  6808. % PUTV(MODFVEC,I,MODF:=REDUCE!-MOD!-P FAC);
  6809. % PUTV(ALPHAVEC,I,CDR GET!-ALPHA MODF) >>;
  6810. % FOR I:=1:N DO <<
  6811. % PRINC "f("; % PRINC I; % PRINC ") = ";
  6812. % FAC!-PRINTSF GETV(FACTORVEC,I);
  6813. % PRINC "f("; % PRINC I; % PRINC ") mod p = ";
  6814. % FAC!-PRINTSF GETV(MODFVEC,I);
  6815. % PRINC "a("; % PRINC I; % PRINC ") = ";
  6816. % FAC!-PRINTSF GETV(ALPHAVEC,I) >>;
  6817. % SET!-MODULUS OM
  6818. % END;
  6819. SYMBOLIC PROCEDURE RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,FACLIST,N);
  6820. BEGIN SCALAR I,OM,FACPAIRLIST,CFP!-MOD!-P,FHATLIST;
  6821. CURRENT!-FACTOR!-PRODUCT:=POLY;
  6822. OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  6823. CFP!-MOD!-P:=REDUCE!-MOD!-P CURRENT!-FACTOR!-PRODUCT;
  6824. I:=0;
  6825. FACPAIRLIST:=FOR EACH FAC IN FACLIST COLLECT <<
  6826. I:= I #+ 1;
  6827. (FAC . REDUCE!-MOD!-P FAC) >>;
  6828. FHATLIST:=FOR EACH FACC IN FACPAIRLIST COLLECT
  6829. QUOTFAIL!-MOD!-P(CFP!-MOD!-P,CDR FACC);
  6830. IF FACTORS!-DONE THEN ALPHALIST:=
  6831. FIND!-ALPHAS!-IN!-A!-RING(I,
  6832. FOR EACH FACPR IN FACPAIRLIST COLLECT CDR FACPR,
  6833. FHATLIST,1);
  6834. % a bug has surfaced such that the alphas get out of step
  6835. % in this case so recalculate them to stop the error for now;
  6836. I:=0;
  6837. FOR EACH FACPAIR IN FACPAIRLIST DO <<
  6838. PUTV(FACTORVEC,I:=IADD1 I,CAR FACPAIR);
  6839. PUTV(MODFVEC,I,CDR FACPAIR);
  6840. PUTV(ALPHAVEC,I,CDR GET!-ALPHA CDR FACPAIR) >>;
  6841. % FOR I:=1:N DO <<
  6842. % PRINC "f("; % PRINC I; % PRINC ") = ";
  6843. % FAC!-PRINTSF GETV(FACTORVEC,I);
  6844. % PRINC "f("; % PRINC I; % PRINC ") mod p = ";
  6845. % FAC!-PRINTSF GETV(MODFVEC,I);
  6846. % PRINC "a("; % PRINC I; % PRINC ") = ";
  6847. % FAC!-PRINTSF GETV(ALPHAVEC,I) >>;
  6848. SET!-MODULUS OM
  6849. END;
  6850. SYMBOLIC PROCEDURE QUADRATIC!-STEP(M,R);
  6851. % code for adjusting the hensel variables to take quadratic
  6852. % steps in the growing process;
  6853. BEGIN SCALAR W,S,CFP!-MOD!-P;
  6854. SET!-MODULUS M;
  6855. CFP!-MOD!-P:=REDUCE!-MOD!-P CURRENT!-FACTOR!-PRODUCT;
  6856. FOR I:=1:R DO PUTV(FACVEC,I,REDUCE!-MOD!-P GETV(FACTORVEC,I));
  6857. FOR I:=1:R DO PUTV(FHATVEC,I,
  6858. QUOTFAIL!-MOD!-P(CFP!-MOD!-P,GETV(FACVEC,I)));
  6859. W:=FORM!-SUM!-AND!-PRODUCT!-MOD!-M(ALPHAVEC,FHATVEC,R);
  6860. W:=!*MOD2F PLUS!-MOD!-P(1,MINUS!-MOD!-P W);
  6861. S:=QUOTFAIL(W,DELTAM);
  6862. SET!-MODULUS DELTAM;
  6863. S:=!*F2MOD S;
  6864. % Boxes S up to look like a poly mod deltam;
  6865. FOR I:=1:R DO <<
  6866. W:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(S,GETV(ALPHAVEC,I)),
  6867. GETV(MODFVEC,I));
  6868. PUTV(ALPHAVEC,I,
  6869. ADDF(!*MOD2F GETV(ALPHAVEC,I),MULTF(!*MOD2F W,DELTAM))) >>;
  6870. S:=MODFVEC;
  6871. MODFVEC:=FACVEC;
  6872. FACVEC:=S;
  6873. DELTAM:=M;
  6874. % this is our new growth rate;
  6875. SET!-MODULUS DELTAM;
  6876. FOR I:=1:R DO <<
  6877. PUTV(FACVEC,I,"RUBBISH");
  6878. % we will want to overwrite facvec next time so we
  6879. % had better point it to the old (no longer needed)
  6880. % modvec. Also mark it as containing rubbish for safety;
  6881. PUTV(ALPHAVEC,I,!*F2MOD GETV(ALPHAVEC,I)) >>;
  6882. % Make sure the alphas are boxed up as being mod new deltam;
  6883. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6884. PRINTSTR "The new modular polynomials are chosen such that:";
  6885. TERPRI();
  6886. PRIN2!* " a(1)*h(1) + ... + a(";
  6887. PRIN2!* R;
  6888. PRIN2!* ")*h("; PRIN2!* R;
  6889. PRIN2!* ") = 1 mod "; PRINTSTR M;
  6890. TERPRI();
  6891. PRINTSTR " where h(i)=(product of all f(j) [see below])/f(i)";
  6892. PRINTSTR " and degree of a(i) < degree of f(i).";
  6893. FOR I:=1:R DO <<
  6894. PRIN2!* " a("; PRIN2!* I; PRIN2!* ")=";
  6895. FAC!-PRINTSF GETV(ALPHAVEC,I);
  6896. PRIN2!* " f("; PRIN2!* I; PRIN2!* ")=";
  6897. FAC!-PRINTSF GETV(MODFVEC,I) >>
  6898. >>
  6899. END;
  6900. SYMBOLIC PROCEDURE TERMS!-DONE(FVEC,DELFVEC,M);
  6901. BEGIN SCALAR FLIST,DELFLIST;
  6902. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  6903. FLIST:=GETV(FVEC,I) . FLIST;
  6904. DELFLIST:=GETV(DELFVEC,I) . DELFLIST >>;
  6905. RETURN TERMS!.DONE(NUMBER!-OF!-FACTORS,FLIST,DELFLIST,
  6906. NUMBER!-OF!-FACTORS,M)
  6907. END;
  6908. SYMBOLIC PROCEDURE TERMS!.DONE(N,FLIST,DELFLIST,R,M);
  6909. IF N=1 THEN (CAR FLIST) . (CAR DELFLIST)
  6910. ELSE BEGIN SCALAR K,I,F1,F2,DELF1,DELF2;
  6911. K:=N/2; I:=1;
  6912. FOR EACH F IN FLIST DO
  6913. << IF I>K THEN F2:=(F . F2)
  6914. ELSE F1:=(F . F1);
  6915. I:=I+1 >>;
  6916. I:=1;
  6917. FOR EACH DELF IN DELFLIST DO
  6918. << IF I>K THEN DELF2:=(DELF . DELF2)
  6919. ELSE DELF1:=(DELF . DELF1);
  6920. I:=I+1 >>;
  6921. F1:=TERMS!.DONE(K,F1,DELF1,R,M);
  6922. DELF1:=CDR F1; F1:=CAR F1;
  6923. F2:=TERMS!.DONE(N-K,F2,DELF2,R,M);
  6924. DELF2:=CDR F2; F2:=CAR F2;
  6925. DELF1:=
  6926. ADDF(ADDF(
  6927. MULTF(F1,DELF2),
  6928. MULTF(F2,DELF1)),
  6929. MULTF(MULTF(DELF1,M),DELF2));
  6930. IF N=R THEN RETURN DELF1;
  6931. RETURN (MULTF(F1,F2) . DELF1)
  6932. END;
  6933. SYMBOLIC PROCEDURE TRY!.COMBINING(L,POLY,M,SOFAR);
  6934. % l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly
  6935. % but no f(i) divides poly over the integers. we find the combinations
  6936. % of the f(i) that yield the true factors of poly over the integers.
  6937. % sofar is a list of these factors found so far. ;
  6938. IF POLY=1 THEN
  6939. IF NULL L THEN SOFAR
  6940. ELSE ERRORF(LIST("TOO MANY BAD FACTORS:",L))
  6941. ELSE BEGIN SCALAR N,RES,FF,V,W,W1,COMBINED!.FACTORS,LL;
  6942. N:=LENGTH L;
  6943. IF N=1 THEN
  6944. IF LDEG CAR L > (LDEG POLY)/2 THEN
  6945. RETURN ('ONE! BAD! FACTOR . SOFAR)
  6946. ELSE ERRORF(LIST("ONE BAD FACTOR DOES NOT FIT:",L));
  6947. IF N=2 OR N=3 THEN <<
  6948. W:=LC CDAR L; % The LC of all the factors is the same;
  6949. WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W);
  6950. % poly's LC may be a higher power of w than we want
  6951. % and we must return a result with the same
  6952. % LC as each of the combined factors;
  6953. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6954. PRINTSTR "We combine:";
  6955. FOR EACH LF IN L DO FAC!-PRINTSF CDR LF;
  6956. PRIN2!* " mod "; PRIN2!* M;
  6957. PRINTSTR " to give correct factor:";
  6958. FAC!-PRINTSF POLY >>;
  6959. COMBINE!.ALPHAS(L,T);
  6960. RETURN (POLY . SOFAR) >>;
  6961. LL:=FOR EACH FF IN L COLLECT (CDR FF . CAR FF);
  6962. FOR K:=2:(N/2) DO <<
  6963. W:=KOUTOF(K,IF 2*K=N THEN CDR L ELSE L,NIL);
  6964. WHILE W AND (V:=FACTOR!-TRIALDIV(POLY,CAR W,M,LL))='DIDNTGO DO
  6965. << W:=CDR W;
  6966. WHILE W AND
  6967. ((CAR W = '!*LAZYADJOIN) OR (CAR W = '!*LAZYKOUTOF)) DO
  6968. IF CAR W= '!*LAZYADJOIN THEN
  6969. W:=LAZY!-ADJOIN(CADR W,CADDR W,CADR CDDR W)
  6970. ELSE W:=KOUTOF(CADR W,CADDR W,CADR CDDR W)
  6971. >>;
  6972. IF NOT(V='DIDNTGO) THEN <<
  6973. FF:=CAR V; V:=CDR V;
  6974. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6975. PRINTSTR "We combine:";
  6976. FOR EACH A IN CAR W DO FAC!-PRINTSF A;
  6977. PRIN2!* " mod "; PRIN2!* M;
  6978. PRINTSTR " to give correct factor:";
  6979. FAC!-PRINTSF FF >>;
  6980. FOR EACH A IN CAR W DO <<
  6981. W1:=L;
  6982. WHILE NOT (A = CDAR W1) DO W1:=CDR W1;
  6983. COMBINED!.FACTORS:=CAR W1 . COMBINED!.FACTORS;
  6984. L:=DELETE(CAR W1,L) >>;
  6985. COMBINE!.ALPHAS(COMBINED!.FACTORS,T);
  6986. RETURN RES:=TRY!.COMBINING(L,V,M,FF . SOFAR) >>
  6987. >>;
  6988. IF RES THEN RETURN RES
  6989. ELSE <<
  6990. W:=LC CDAR L; % The LC of all the factors is the same;
  6991. WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W);
  6992. % poly's LC may be a higher power of w than we want
  6993. % and we must return a result with the same
  6994. % LC as each of the combined factors;
  6995. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  6996. PRINTSTR "We combine:";
  6997. FOR EACH FF IN L DO FAC!-PRINTSF CDR FF;
  6998. PRIN2!* " mod "; PRIN2!* M;
  6999. PRINTSTR " to give correct factor:";
  7000. FAC!-PRINTSF POLY >>;
  7001. COMBINE!.ALPHAS(L,T);
  7002. RETURN (POLY . SOFAR) >>
  7003. END;
  7004. SYMBOLIC PROCEDURE KOUTOF(K,L,SOFAR);
  7005. % produces all permutations of length k from list l accumulating them
  7006. % in sofar as we go. we use lazy evaluation in that this results in
  7007. % a permutation dotted with:
  7008. % ( '!*lazy . (argument for eval) )
  7009. % except when k=1 when the permutations are explicitly given.;
  7010. IF K=1 THEN APPEND(
  7011. FOR EACH F IN L COLLECT LIST CDR F,SOFAR)
  7012. ELSE IF K>LENGTH L THEN SOFAR
  7013. ELSE <<
  7014. WHILE EQCAR(L,'!*LAZYADJOIN) OR EQCAR(L,'!*LAZYKOUTOF) DO
  7015. IF CAR L='!*LAZYADJOIN THEN
  7016. L := LAZY!-ADJOIN(CADR L,CADDR L,CADR CDDR L)
  7017. ELSE L := KOUTOF(CADR L,CADDR L,CADR CDDR L);
  7018. IF K=LENGTH L THEN
  7019. (FOR EACH LL IN L COLLECT CDR LL ) . SOFAR
  7020. ELSE KOUTOF(K,CDR L,
  7021. LIST('!*LAZYADJOIN,CDAR L,
  7022. LIST('!*LAZYKOUTOF,(K-1),CDR L,NIL),
  7023. SOFAR)) >>;
  7024. SYMBOLIC PROCEDURE LAZY!-ADJOIN(ITEM,L,TAIL);
  7025. % dots item with each element in l using lazy evaluation on l.
  7026. % if l is null tail results;
  7027. << WHILE EQCAR(L,'!*LAZYADJOIN) OR EQCAR(L,'!*LAZYKOUTOF) DO
  7028. IF CAR L ='!*LAZYADJOIN THEN
  7029. L:=LAZY!-ADJOIN(CADR L,CADDR L,CADR CDDR L)
  7030. ELSE L:=KOUTOF(CADR L,CADDR L,CADR CDDR L);
  7031. IF NULL L THEN TAIL
  7032. ELSE (ITEM . CAR L) .
  7033. IF NULL CDR L THEN TAIL
  7034. ELSE LIST('!*LAZYADJOIN,ITEM,CDR L,TAIL) >>;
  7035. SYMBOLIC PROCEDURE FACTOR!-TRIALDIV(POLY,FLIST,M,LLIST);
  7036. % Combines the factors in FLIST mod M and test divides the result
  7037. % into POLY (over integers) to see if it goes. If it doesn't
  7038. % then DIDNTGO is returned, else the pair (D . Q) is
  7039. % returned where Q is the quotient obtained and D is the product
  7040. % of the factors mod M;
  7041. IF POLYZEROP POLY THEN ERRORF "Test dividing into zero?"
  7042. ELSE BEGIN SCALAR D,Q;
  7043. D:=COMBINE(FLIST,M,LLIST);
  7044. IF DIDNTGO(Q:=QUOTF(POLY,CAR D)) THEN <<
  7045. FACTOR!-TRACE PRINTSTR " it didn't go";
  7046. RETURN 'DIDNTGO >>
  7047. ELSE <<
  7048. FACTOR!-TRACE PRINTSTR " it worked !";
  7049. RETURN (CAR D . QUOTF(Q,CDR D)) >>
  7050. END;
  7051. SYMBOLIC PROCEDURE COMBINE(FLIST,M,L);
  7052. % multiply factors in flist mod m;
  7053. % L is a list of the factors for use in FACTOR!-TRACE;
  7054. BEGIN SCALAR OM,RES,W,LCF,LCFINV,LCFPROD;
  7055. FACTOR!-TRACE <<
  7056. PRIN2!* "We combine factors ";
  7057. FOR EACH FF IN FLIST DO <<
  7058. W:=ASSOC(FF,L);
  7059. PRIN2!* "f(";
  7060. PRIN2!* CDR W;
  7061. PRIN2!* "), " >> ;
  7062. PRIN2!* "and try dividing : " >>;
  7063. LCF := LC CAR FLIST; % ALL LEADING COEFFTS SHOULD BE THE SAME;
  7064. LCFPROD := 1;
  7065. % This is one of only two places in the entire factorizer where
  7066. % it is ever necessary to use a modulus larger than word-size;
  7067. IF M>LARGEST!-SMALL!-MODULUS THEN <<
  7068. OM:=SET!-GENERAL!-MODULUS M;
  7069. LCFINV := GENERAL!-MODULAR!-RECIPROCAL LCF;
  7070. RES:=GENERAL!-REDUCE!-MOD!-P CAR FLIST;
  7071. FOR EACH FF IN CDR FLIST DO <<
  7072. IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST";
  7073. RES:=GENERAL!-TIMES!-MOD!-P(
  7074. GENERAL!-TIMES!-MOD!-P(LCFINV,
  7075. GENERAL!-REDUCE!-MOD!-P FF),RES);
  7076. LCFPROD := LCFPROD*LCF >>;
  7077. RES:=GENERAL!-MAKE!-MODULAR!-SYMMETRIC RES;
  7078. SET!-MODULUS OM;
  7079. RETURN (RES . LCFPROD) >>
  7080. ELSE <<
  7081. OM:=SET!-MODULUS M;
  7082. LCFINV := MODULAR!-RECIPROCAL LCF;
  7083. RES:=REDUCE!-MOD!-P CAR FLIST;
  7084. FOR EACH FF IN CDR FLIST DO <<
  7085. IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST";
  7086. RES:=TIMES!-MOD!-P(TIMES!-MOD!-P(LCFINV,REDUCE!-MOD!-P FF),RES);
  7087. LCFPROD := LCFPROD*LCF >>;
  7088. RES:=MAKE!-MODULAR!-SYMMETRIC RES;
  7089. SET!-MODULUS OM;
  7090. RETURN (RES . LCFPROD) >>
  7091. END;
  7092. SYMBOLIC PROCEDURE COMBINE!.ALPHAS(FLIST,FIXLCS);
  7093. % combine the alphas associated with each of these factors to
  7094. % give the one alpha for their combination;
  7095. BEGIN SCALAR F1,A1,FF,AA,OLDM,W,LCFAC,LCFINV,SAVEFLIST;;
  7096. OLDM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE;
  7097. FLIST:=FOR EACH FAC IN FLIST COLLECT <<
  7098. SAVEFLIST:= (REDUCE!-MOD!-P CDR FAC) . SAVEFLIST;
  7099. (CAR FAC) . CAR SAVEFLIST >>;
  7100. IF FIXLCS THEN <<
  7101. LCFINV:=MODULAR!-RECIPROCAL LC CDAR FLIST;
  7102. LCFAC:=MODULAR!-EXPT(LC CDAR FLIST,SUB1 LENGTH FLIST)
  7103. >>
  7104. ELSE << LCFINV:=1; LCFAC:=1 >>;
  7105. % If FIXLCS is set then we have combined n factors
  7106. % (each with the same l.c.) to give one and we only need one
  7107. % l.c. in the result, we have divided the combination by
  7108. % lc**(n-1) and we must be sure to do the same for the
  7109. % alphas.;
  7110. FF:=CDAR FLIST;
  7111. AA:=CDR GET!-ALPHA FF;
  7112. FLIST:=CDR FLIST;
  7113. WHILE FLIST DO <<
  7114. F1:=CDAR FLIST;
  7115. A1:=CDR GET!-ALPHA F1;
  7116. FLIST:=CDR FLIST;
  7117. AA:=PLUS!-MOD!-P(TIMES!-MOD!-P(AA,F1),TIMES!-MOD!-P(A1,FF));
  7118. FF:=TIMES!-MOD!-P(FF,TIMES!-MOD!-P(LCFINV,F1))
  7119. >>;
  7120. FOR EACH A IN ALPHALIST DO
  7121. IF NOT MEMBER(CAR A,SAVEFLIST) THEN
  7122. FLIST:=(CAR A . IF LCFAC=1 THEN CDR A
  7123. ELSE TIMES!-MOD!-P(CDR A,LCFAC)) . FLIST;
  7124. ALPHALIST:=(FF . AA) . FLIST;
  7125. SET!-MODULUS OLDM
  7126. END;
  7127. %*********************************************************************;
  7128. % The following code is for dividing out factors in the middle
  7129. % of the Hensel construction and adjusting all the associated
  7130. % variables that go with it.
  7131. %;
  7132. SYMBOLIC PROCEDURE ADJUST!-GROWTH(FACDONE,K,M);
  7133. % One factor (at least) divides out so we can reconfigure the
  7134. % problem for Hensel constrn giving a smaller growth and hopefully
  7135. % reducing the coefficient bound considerably;
  7136. BEGIN SCALAR W,U,BOUND!-SCALE,MODFLIST,FACTORLIST,FHATLIST,
  7137. MODFDONE,B;
  7138. FACTORLIST:=VEC2LIST!-WITHOUT!-K(FACTORVEC,K);
  7139. MODFLIST:=VEC2LIST!-WITHOUT!-K(MODFVEC,K);
  7140. FHATLIST:=VEC2LIST!-WITHOUT!-K(FHATVEC,K);
  7141. W:=NUMBER!-OF!-FACTORS;
  7142. MODFDONE:=GETV(MODFVEC,K);
  7143. TOP:
  7144. FACTORS!-DONE:=FACDONE . FACTORS!-DONE;
  7145. IF (NUMBER!-OF!-FACTORS:=NUMBER!-OF!-FACTORS #- 1)=1 THEN <<
  7146. FACTORS!-DONE:=HENSEL!-POLY . FACTORS!-DONE;
  7147. NUMBER!-OF!-FACTORS:=0;
  7148. HENSEL!-POLY:=1;
  7149. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  7150. PRINTSTR " All factors found:";
  7151. FOR EACH FD IN FACTORS!-DONE DO FAC!-PRINTSF FD >>;
  7152. RETURN POLYZERO >>;
  7153. FHATLIST:=FOR EACH FHAT IN FHATLIST COLLECT
  7154. QUOTFAIL!-MOD!-P(IF NULL FHAT THEN POLYZERO ELSE FHAT,MODFDONE);
  7155. U:=COMFAC FACDONE; % Take contents and prim. parts;
  7156. IF CAR U THEN
  7157. ERRORF(LIST("Factor divisible by main variable: ",FACDONE,CAR U));
  7158. FACDONE:=QUOTFAIL(FACDONE,CDR U);
  7159. BOUND!-SCALE:=CDR U;
  7160. IF NOT((B:=LC FACDONE)=1) THEN BEGIN SCALAR B!-INV,OLD!-M;
  7161. HENSEL!-POLY:=QUOTFAIL(HENSEL!-POLY,B**NUMBER!-OF!-FACTORS);
  7162. B!-INV:=MODULAR!-RECIPROCAL MODULAR!-NUMBER B;
  7163. MODFLIST:=FOR EACH MODF IN MODFLIST COLLECT
  7164. TIMES!-MOD!-P(B!-INV,MODF);
  7165. % This is one of only two places in the entire factorizer where
  7166. % it is ever necessary to use a modulus larger than word-size;
  7167. IF M>LARGEST!-SMALL!-MODULUS THEN <<
  7168. OLD!-M:=SET!-GENERAL!-MODULUS M;
  7169. FACTORLIST:=FOR EACH FACC IN FACTORLIST COLLECT
  7170. ADJOIN!-TERM(LPOW FACC,QUOTFAIL(LC FACC,B),
  7171. GENERAL!-MAKE!-MODULAR!-SYMMETRIC(
  7172. GENERAL!-TIMES!-MOD!-P(
  7173. GENERAL!-MODULAR!-RECIPROCAL GENERAL!-MODULAR!-NUMBER B,
  7174. GENERAL!-REDUCE!-MOD!-P RED FACC))) >>
  7175. ELSE <<
  7176. OLD!-M:=SET!-MODULUS M;
  7177. FACTORLIST:=FOR EACH FACC IN FACTORLIST COLLECT
  7178. ADJOIN!-TERM(LPOW FACC,QUOTFAIL(LC FACC,B),
  7179. MAKE!-MODULAR!-SYMMETRIC(
  7180. TIMES!-MOD!-P(MODULAR!-RECIPROCAL MODULAR!-NUMBER B,
  7181. REDUCE!-MOD!-P RED FACC))) >>;
  7182. % We must be careful not to destroy the information
  7183. % that we have about the leading coefft;
  7184. SET!-MODULUS OLD!-M;
  7185. FHATLIST:=FOR EACH FHAT IN FHATLIST COLLECT
  7186. TIMES!-MOD!-P(
  7187. MODULAR!-EXPT(B!-INV,NUMBER!-OF!-FACTORS #- 1),FHAT)
  7188. END;
  7189. TRY!-ANOTHER!-FACTOR:
  7190. IF (W:=W #- 1)>0 THEN
  7191. IF NOT DIDNTGO
  7192. (U:=QUOTF(HENSEL!-POLY,FACDONE:=CAR FACTORLIST)) THEN <<
  7193. HENSEL!-POLY:=U;
  7194. FACTORLIST:=CDR FACTORLIST;
  7195. MODFDONE:=CAR MODFLIST;
  7196. MODFLIST:=CDR MODFLIST;
  7197. FHATLIST:=CDR FHATLIST;
  7198. GOTO TOP >>
  7199. ELSE <<
  7200. FACTORLIST:=APPEND(CDR FACTORLIST,LIST CAR FACTORLIST);
  7201. MODFLIST:=APPEND(CDR MODFLIST,LIST CAR MODFLIST);
  7202. FHATLIST:=APPEND(CDR FHATLIST,LIST CAR FHATLIST);
  7203. GOTO TRY!-ANOTHER!-FACTOR >>;
  7204. SET!-FLUIDS!-FOR!-NEWHENSEL(FACTORLIST,FHATLIST,MODFLIST);
  7205. BOUND!-SCALE:=
  7206. BOUND!-SCALE * GET!-COEFFT!-BOUND(
  7207. QUOTFAIL(HENSEL!-POLY,BOUND!-SCALE**(NUMBER!-OF!-FACTORS #- 1)),
  7208. LDEG HENSEL!-POLY);
  7209. % We expect the new coefficient bound to be smaller, but on
  7210. % dividing out a factor our polynomial's height may have grown
  7211. % more than enough to compensate in the bound formula for
  7212. % the drop in degree. Anyway, the bound we computed last time
  7213. % will still be valid, so let's stick with the smaller;
  7214. IF BOUND!-SCALE < COEFFTBD THEN COEFFTBD := BOUND!-SCALE;
  7215. W:=QUOTFAIL(ADDF(HENSEL!-POLY,NEGF CURRENT!-FACTOR!-PRODUCT),
  7216. M/DELTAM);
  7217. IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
  7218. PRINTSTR " Factors found to be correct:";
  7219. FOR EACH FD IN FACTORS!-DONE DO
  7220. FAC!-PRINTSF FD;
  7221. PRINTSTR "Remaining factors are:";
  7222. PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",FACTORVEC);
  7223. PRIN2!* "New coefficient bound is "; PRINTSTR COEFFTBD;
  7224. PRIN2!* " and the residue is now "; FAC!-PRINTSF W >>;
  7225. RETURN W
  7226. END;
  7227. SYMBOLIC PROCEDURE VEC2LIST!-WITHOUT!-K(V,K);
  7228. % Turn a vector into a list leaving out Kth element;
  7229. BEGIN SCALAR W;
  7230. FOR I:=1:NUMBER!-OF!-FACTORS DO
  7231. IF NOT(I=K) THEN W:=GETV(V,I) . W;
  7232. RETURN W
  7233. END;
  7234. SYMBOLIC PROCEDURE SET!-FLUIDS!-FOR!-NEWHENSEL(FLIST,FHATLIST,MODFLIST);
  7235. << CURRENT!-FACTOR!-PRODUCT:=1;
  7236. ALPHALIST:=
  7237. FIND!-ALPHAS!-IN!-A!-RING(NUMBER!-OF!-FACTORS,MODFLIST,FHATLIST,1);
  7238. FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO <<
  7239. PUTV(FACTORVEC,I,CAR FLIST);
  7240. PUTV(MODFVEC,I,CAR MODFLIST);
  7241. PUTV(FHATVEC,I,CAR FHATLIST);
  7242. PUTV(ALPHAVEC,I,CDR GET!-ALPHA CAR MODFLIST);
  7243. CURRENT!-FACTOR!-PRODUCT:=MULTF(CAR FLIST,CURRENT!-FACTOR!-PRODUCT);
  7244. FLIST:=CDR FLIST;
  7245. MODFLIST:=CDR MODFLIST;
  7246. FHATLIST:=CDR FHATLIST >>
  7247. >>;
  7248. SYMBOLIC PROCEDURE SET!-HENSEL!-FLUIDS!-BACK P;
  7249. % After the Hensel growth we must be careful to set back any fluids
  7250. % that have been changed when we divided out a factor in the middle
  7251. % of growing. Since calculating the alphas involves modular division
  7252. % we cannot do it mod DELTAM which is generally a non-trivial power of
  7253. % P (prime). So we calculate them mod P and if necessary we can do a
  7254. % few quadratic growth steps later. ;
  7255. BEGIN SCALAR N,FD,MODFLIST,FULLF,MODF;
  7256. SET!-MODULUS P;
  7257. DELTAM:=P;
  7258. N:=NUMBER!-OF!-FACTORS #+ LENGTH (FD:=FACTORS!-DONE);
  7259. CURRENT!-FACTOR!-PRODUCT:=HENSEL!-POLY;
  7260. FOR I:=(NUMBER!-OF!-FACTORS #+ 1):N DO <<
  7261. PUTV(FACTORVEC,I,FULLF:=CAR FD);
  7262. PUTV(MODFVEC,I,MODF:=REDUCE!-MOD!-P FULLF);
  7263. CURRENT!-FACTOR!-PRODUCT:=MULTF(FULLF,CURRENT!-FACTOR!-PRODUCT);
  7264. MODFLIST:=MODF . MODFLIST;
  7265. FD:=CDR FD >>;
  7266. FOR I:=1:NUMBER!-OF!-FACTORS DO <<
  7267. MODF:=REDUCE!-MOD!-P !*MOD2F GETV(MODFVEC,I);
  7268. % need to 'unbox' a modpoly before reducing it mod p as we
  7269. % know that the input modpoly is wrt a larger modulus
  7270. % (otherwise this would be a stupid thing to do anyway!)
  7271. % and so we are just pretending it is a full poly;
  7272. MODFLIST:=MODF . MODFLIST;
  7273. PUTV(MODFVEC,I,MODF) >>;
  7274. ALPHALIST:=ALPHAS(N,MODFLIST,1);
  7275. FOR I:=1:N DO PUTV(ALPHAVEC,I,CDR GET!-ALPHA GETV(MODFVEC,I));
  7276. NUMBER!-OF!-FACTORS:=N
  7277. END;
  7278. ENDMODULE;
  7279. MODULE VECPOLY;
  7280. %**********************************************************************;
  7281. %
  7282. % copyright (c) university of cambridge, england 1979
  7283. %
  7284. %**********************************************************************;
  7285. %**********************************************************************;
  7286. % Routines for working with modular univariate polynomials
  7287. % stored as vectors. Used to avoid unwarranted storage management
  7288. % in the mod-p factorization process;
  7289. SAFE!-FLAG:=CARCHECK 0;
  7290. SYMBOLIC PROCEDURE COPY!-VECTOR(A,DA,B);
  7291. % Copy A into B;
  7292. << FOR I:=0:DA DO
  7293. PUTV(B,I,GETV(A,I));
  7294. DA >>;
  7295. SYMBOLIC PROCEDURE TIMES!-IN!-VECTOR(A,DA,B,DB,C);
  7296. % Put the product of A and B into C and return its degree.
  7297. % C must not overlap with either A or B;
  7298. BEGIN
  7299. SCALAR DC,IC,W;
  7300. IF DA#<0 OR DB#<0 THEN RETURN MINUS!-ONE;
  7301. DC:=DA#+DB;
  7302. FOR I:=0:DC DO PUTV(C,I,0);
  7303. FOR IA:=0:DA DO <<
  7304. W:=GETV(A,IA);
  7305. FOR IB:=0:DB DO <<
  7306. IC:=IA#+IB;
  7307. PUTV(C,IC,MODULAR!-PLUS(GETV(C,IC),
  7308. MODULAR!-TIMES(W,GETV(B,IB)))) >> >>;
  7309. RETURN DC
  7310. END;
  7311. SYMBOLIC PROCEDURE QUOTFAIL!-IN!-VECTOR(A,DA,B,DB);
  7312. % Overwrite A with (A/B) and return degree of result.
  7313. % The quotient must be exact;
  7314. IF DA#<0 THEN DA
  7315. ELSE IF DB#<0 THEN ERRORF "Attempt to divide by zero"
  7316. ELSE IF DA#<DB THEN ERRORF "Bad degrees in QUOTFAIL-IN-VECTOR"
  7317. ELSE BEGIN
  7318. SCALAR DC;
  7319. DC:=DA#-DB; % Degree of result;
  7320. FOR I:=DC STEP -1 UNTIL 0 DO BEGIN
  7321. SCALAR Q;
  7322. Q:=MODULAR!-QUOTIENT(GETV(A,DB#+I),GETV(B,DB));
  7323. FOR J:=0:DB#-1 DO
  7324. PUTV(A,I#+J,MODULAR!-DIFFERENCE(GETV(A,I#+J),
  7325. MODULAR!-TIMES(Q,GETV(B,J))));
  7326. PUTV(A,DB#+I,Q)
  7327. END;
  7328. FOR I:=0:DB#-1 DO IF GETV(A,I) NEQ 0 THEN
  7329. ERRORF "Quotient not exact in QUOTFAIL!-IN!-VECTOR";
  7330. FOR I:=0:DC DO
  7331. PUTV(A,I,GETV(A,DB#+I));
  7332. RETURN DC
  7333. END;
  7334. SYMBOLIC PROCEDURE REMAINDER!-IN!-VECTOR(A,DA,B,DB);
  7335. % Overwrite the vector A with the remainder when A is
  7336. % divided by B, and return the degree of the result;
  7337. BEGIN
  7338. SCALAR DELTA,DB!-1,RECIP!-LC!-B,W;
  7339. IF DB=0 THEN RETURN MINUS!-ONE
  7340. ELSE IF DB=MINUS!-ONE THEN ERRORF "ATTEMPT TO DIVIDE BY ZERO";
  7341. RECIP!-LC!-B:=MODULAR!-MINUS MODULAR!-RECIPROCAL GETV(B,DB);
  7342. DB!-1:=DB#-1; % Leading coeff of B treated specially, hence this;
  7343. WHILE NOT((DELTA:=DA#-DB) #< 0) DO <<
  7344. W:=MODULAR!-TIMES(RECIP!-LC!-B,GETV(A,DA));
  7345. FOR I:=0:DB!-1 DO
  7346. PUTV(A,I#+DELTA,MODULAR!-PLUS(GETV(A,I#+DELTA),
  7347. MODULAR!-TIMES(GETV(B,I),W)));
  7348. DA:=DA#-1;
  7349. WHILE NOT(DA#<0) AND GETV(A,DA)=0 DO DA:=DA#-1 >>;
  7350. RETURN DA
  7351. END;
  7352. SYMBOLIC PROCEDURE EVALUATE!-IN!-VECTOR(A,DA,N);
  7353. % Evaluate A at N;
  7354. BEGIN
  7355. SCALAR R;
  7356. R:=GETV(A,DA);
  7357. FOR I:=DA#-1 STEP -1 UNTIL 0 DO
  7358. R:=MODULAR!-PLUS(GETV(A,I),
  7359. MODULAR!-TIMES(R,N));
  7360. RETURN R
  7361. END;
  7362. SYMBOLIC PROCEDURE GCD!-IN!-VECTOR(A,DA,B,DB);
  7363. % Overwrite A with the gcd of A and B. On input A and B are
  7364. % vectors of coefficients, representing polynomials
  7365. % of degrees DA and DB. Return DG, the degree of the gcd;
  7366. BEGIN
  7367. SCALAR W;
  7368. IF DA=0 OR DB=0 THEN << PUTV(A,0,1); RETURN 0 >>
  7369. ELSE IF DA#<0 OR DB#<0 THEN ERRORF "GCD WITH ZERO NOT ALLOWED";
  7370. TOP:
  7371. % Reduce the degree of A;
  7372. DA:=REMAINDER!-IN!-VECTOR(A,DA,B,DB);
  7373. IF DA=0 THEN << PUTV(A,0,1); RETURN 0 >>
  7374. ELSE IF DA=MINUS!-ONE THEN <<
  7375. W:=MODULAR!-RECIPROCAL GETV(B,DB);
  7376. FOR I:=0:DB DO PUTV(A,I,MODULAR!-TIMES(GETV(B,I),W));
  7377. RETURN DB >>;
  7378. % Now reduce degree of B;
  7379. DB:=REMAINDER!-IN!-VECTOR(B,DB,A,DA);
  7380. IF DB=0 THEN << PUTV(A,0,1); RETURN 0 >>
  7381. ELSE IF DB=MINUS!-ONE THEN <<
  7382. W:=MODULAR!-RECIPROCAL GETV(A,DA);
  7383. IF NOT (W=1) THEN
  7384. FOR I:=0:DA DO PUTV(A,I,MODULAR!-TIMES(GETV(A,I),W));
  7385. RETURN DA >>;
  7386. GO TO TOP
  7387. END;
  7388. CARCHECK SAFE!-FLAG;
  7389. ENDMODULE;
  7390. MODULE ZMODP;
  7391. % *******************************************************************
  7392. %
  7393. % copyright (c) university of cambridge, england 1979
  7394. %
  7395. % *******************************************************************;
  7396. % modular arithmetic for use in univariate factorization
  7397. % routines;
  7398. SYMBOLIC PROCEDURE SET!-MODULUS P;
  7399. IF NOT NUMBERP P OR P=0 THEN CURRENT!-MODULUS
  7400. ELSE BEGIN
  7401. SCALAR PREVIOUS!-MODULUS;
  7402. PREVIOUS!-MODULUS:=CURRENT!-MODULUS;
  7403. CURRENT!-MODULUS:=P;
  7404. MODULUS!/2:=P/2;
  7405. SET!-SMALL!-MODULUS P;
  7406. RETURN PREVIOUS!-MODULUS
  7407. END;
  7408. SYMBOLIC PROCEDURE MODULAR!-EXPT(A,N);
  7409. % a**n;
  7410. IF N=0 THEN 1
  7411. ELSE IF N=1 THEN A
  7412. ELSE BEGIN
  7413. SCALAR X;
  7414. X:=MODULAR!-EXPT(A,IQUOTIENT(N,2));
  7415. X:=MODULAR!-TIMES(X,X);
  7416. IF NOT (IREMAINDER(N,2) = 0) THEN X:=MODULAR!-TIMES(X,A);
  7417. RETURN X
  7418. END;
  7419. LISP SET!-MODULUS(1) ; % forces everything into a standard state;
  7420. ENDMODULE;
  7421. END;