1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314 |
- %==========================================================================%
- % GRGcomm.sl Main Commands %
- %==========================================================================%
- % GRG 3.2 Standard Lisp Source Code (C) 1988-97 Vadim V. Zhytnikov %
- %==========================================================================%
- % This file is distributed without any warranty. You may modify it but you %
- % are not allowed to remove author's name and/or distribute modified file. %
- %==========================================================================%
- %---------- Some General Aux Functions -----------------------------------
- % Data name -> Internal variables list ...
- (de dgood!> (lst)
- (prog (w wa wss)
- (setq w lst)
- (cond ((eqs!> lst '(all)) (return(alldata!>)))) % word!!!
- (setq wss lst)
- (setq lst (assocf!> lst ![datl!]))
- (cond ((and (null lst) w (null(cdr w)) (idp(car w)))
- (progn (setq wa (incomiv!>(explode(car w))))
- (cond ((flagp wa '!+ivar) (setq lst (ncons wa)))))))
- (cond ((null lst) (progn (setq ![er!] 6030)
- (doubl!> wss)
- (return !!er!!))))
- (setq lst (car lst))
- (cond ((atom lst) (setq lst (ncons lst))))
- (setq w (constrpl!> lst))
- (cond ((eq w !!er!!) (return !!er!!)))
- (return lst)))
- % Same but for Write Macro Tensors are alowed ...
- (de dgoodw!> (lst)
- (prog (w wa wss)
- (setq w lst)
- (cond ((eqs!> lst '(all)) (return(alldata!>)))) % word!!!
- (setq wss lst)
- (setq lst (assocf!> lst ![datl!]))
- (cond ((and (null lst) w (null(cdr w)) (idp(car w)))
- (progn (setq wa (incomiv!>(explode(car w))))
- (cond ((or (flagp wa '!+ivar) (flagp wa '!+macros2))
- (setq lst (ncons wa)))))))
- (cond ((null lst) (progn (setq ![er!] 6030)
- (doubl!> wss)
- (return !!er!!))))
- (setq lst (car lst))
- (cond ((atom lst) (setq lst (ncons lst))))
- (setq w (constrpl!> lst))
- (cond ((eq w !!er!!) (return !!er!!)))
- (return lst)))
- % All existing data variables ...
- (de alldata!> nil
- (proc (w lst)
- (setq lst ![datl!])
- (while!> lst
- (cond ((and (atom(cadar lst)) (eval(cadar lst)))
- (setq w (cons (cadar lst) w))))
- (setq lst (cdr lst)))
- (setq lst ![abbr!])
- (while!> lst
- (cond ((eval(car lst)) (setq w (cons (car lst) w))))
- (setq lst (cdr lst)))
- (return(reversip w))))
- % Data variables list modification in correspondence with flags ..
- (de altdata!> (w)
- (cond ((null w) nil)
- ((atom (car w)) (consmem!> (car w) (altdata!>(cdr w))))
- ((eval(caar w)) (appmem!> (cdar w) (altdata!>(cdr w))))
- (t (altdata!>(cdr w)))))
- %----- Commands in `grg.cfg' file ---------------------------------------
- % Package ...
- (dm package!> (w) (list 'package0!> (list 'quote (cdr w))))
- (de package0!> (w)
- (prog (ww)
- (setq ![lower!] (islowercase!>))
- lab
- (cond ((null w) (return nil)))
- (setq ww (loadpack!> (ncons(car w)) nil))
- (cond ((eq ww !!er!!) (prog2 (erm!> ![er!]) (return !!er!!))))
- (setq w (cdr w))
- (go lab)
- ))
- % On ...
- (dm on!> (w) (list 'on0!> (list 'quote (cdr w))))
- (de on0!> (w)
- (prog (ww)
- (setq ![lower!] (islowercase!>))
- lab
- (cond((null w)(return nil)))
- (setq ww (onoff!> (ncons(car w)) t))
- (cond((eq ww !!er!!) (prog2 (erm!> ![er!])(return !!er!!))))
- (setq w (cdr w))
- (go lab)
- ))
- % Off ...
- (dm off!> (w) (list 'off0!> (list 'quote (cdr w))))
- (de off0!> (w)
- (prog (ww)
- (setq ![lower!] (islowercase!>))
- lab
- (cond((null w)(return nil)))
- (setq ww (onoff!> (ncons(car w)) nil))
- (cond((eq ww !!er!!) (prog2 (erm!> ![er!])(return !!er!!))))
- (setq w (cdr w))
- (go lab)
- ))
- % Signature ...
- (dm signature!> (w) (list 'signature0!> (list 'quote (cdr w))))
- (de signature0!> (w)
- (proc (wr ww)
- (setq ww w)
- (while!> ww
- (cond ((equal (car ww) '!+) (setq wr (cons 1 wr)))
- ((equal (car ww) '!-) (setq wr (cons -1 wr)))
- (t (erm!> 9002) (bye)))
- (setq ww (cdr ww)))
- (setq ![sgn!] (reverse wr))
- (setq ![dim!] (length ![sgn!]))
- (cond ((lessp ![dim!] 2) (erm!> 9002) (bye)))
- (tunedim!>) ))
- %----- On ...; and Off ...; commands 20.02.94 -----------------------
- (de onoff!> (lst bool)
- (proc (w wc wo ww)
- (cond ((null lst) (return nil)))
- (setq w (memlist!> '!, lst))
- (cond ((eq w !!er!!) (prog2 (setq ![er!] 1100) (return !!er!!))))
- (while!> w
- (setq wc (car w))
- (cond
- ((or (cdr wc) (not(idp(car wc)))) % bad parameter ...
- (prog2 (setq ![er!] 1100) (return !!er!!))) )
- (setq wc (idtostcase!> (car wc)))
- (cond
- ((flagp wc 'switch) % reduce switch ...
- (progn
- (setq ww (makeswvar!> wc))
- (setq wo (eval ww))
- (cond((not(equal wo bool))(prog2
- (cond
- ((iscsl!>)
- (cond (bool (eval(list 'on (list 'quote (ncons wc)))))
- (t (eval(list 'off (list 'quote (ncons wc)))))))
- (t (cond (bool (eval(list '!~on (list 'quote (ncons wc)))))
- (t (eval(list '!~off (list 'quote (ncons wc))))))))
- (onoff1!> wc bool) ))))) % maybe extra grg tuning ...
- ((flagp wc '!+switch) % grg switch ...
- (progn
- (setq ww (makeswvar!> wc))
- (setq wo (eval ww))
- (cond((not(equal wo bool))
- (onoff1!> wc bool) )) ))
- (t(progn % none of above ...
- (doub!> wc)(setq ![er!] 6402)(return !!er!!))))
- (cond((not(equal wo bool))
- (setq ![flaghis!] (cons (cons wc wo) ![flaghis!]))))
- (setq w (cdr w)))))
- % On/Off GRG switch with tuning ...
- (de onoff1!> (w bool)
- (progn
- (set (makeswvar!> w) bool)
- (setq w (get w '!=tuning)) % tuning required ...
- (cond(w (apply w (list bool))))))
- % On/Off GRG switch without tuning ...
- (de onoff2!> (w bool)
- (set (makeswvar!> w) bool))
- % On/Off GRG switch without tuning but with history ...
- (de onoff3!> (w bool)
- (prog (ww wo)
- (setq ww (makeswvar!> w))
- (setq wo (eval ww))
- (set ww bool)
- (setq ![flaghis!] (cons (cons w wo) ![flaghis!]))))
- % Makes *SWITCH from SWITCH ...
- (de makeswvar!> (w)
- (incom!>(cons '!* (explode2 w))))
- % Tuning for TORSION ...
- (de tunetorsion!> (bool)
- (cond ((and bool (null !*nonmetr)) % Result is Q but N=0
- (put '!#!R!I!C '!=sidxl nil)
- (put '!#!G!T '!=sidxl nil)
- (put '!#!T!D!I '!=sidxl nil)
- (put '!#!T!S!F!L '!=sidxl nil)
- )
- ((and bool !*nonmetr) % Result is Q and N
- (put '!#!R!I!C '!=sidxl nil)
- (put '!#!G!T '!=sidxl nil)
- (put '!#!T!D!I '!=sidxl nil)
- (put '!#!T!S!F!L '!=sidxl nil)
- )
- ((null !*nonmetr) % Result is Q=0 and N=0
- (put '!#!R!I!C '!=sidxl '((s 1 2)))
- (put '!#!G!T '!=sidxl '((s 1 2)))
- (put '!#!T!D!I '!=sidxl '((s 1 2)))
- (put '!#!T!S!F!L '!=sidxl '((s 1 2)))
- )
- ((null !*nonmetr) % Result is Q=0 but N
- (put '!#!R!I!C '!=sidxl nil)
- (put '!#!G!T '!=sidxl nil)
- (put '!#!T!D!I '!=sidxl '((s 1 2)))
- (put '!#!T!S!F!L '!=sidxl '((s 1 2)))
- )
- ))
- % Tuning for NONMETR ...
- (de tunenonmetr!> (bool)
- (cond (bool % Result is N with arbitrary Q
- (put '!#!R!I!C '!=sidxl nil)
- (put '!#!G!T '!=sidxl nil)
- )
- (!*torsion % Result is N=0 but Q
- (put '!#!R!I!C '!=sidxl nil)
- (put '!#!G!T '!=sidxl nil)
- )
- ((null !*torsion) % Result N=0 and Q=0
- (put '!#!R!I!C '!=sidxl '((s 1 2)))
- (put '!#!G!T '!=sidxl '((s 1 2)))
- )
- ))
- %----- Stop; command ----------------------------------------------------
- (de stop!> nil !!stop!! )
- %----- Next; command ----------------------------------------------------
- (de next!> nil !!next!! )
- %----- Pause; command ---------------------------------------------------
- (de pause!> nil
- (proc(w)
- (cond (![pause!] (return t))
- (t (prin2 "Pausing ...") (terpri)
- (setq ![pause!] t)))
- (loop!> (setq w (runcom!> nil))
- (exitif (or (eq w !!stop!!) (eq w !!next!!))))
- (setq ![pause!] nil)
- (return w)))
- %----- Inverse ; command ------------------------------------------------
- (de invi!> (lst)
- (prog (wa wb)
- (cond((null lst)(return nil)))
- (setq lst (memlist!> '!, lst))
- (cond((or (eq lst !!er!!) (not(eqn(length lst)2)) )
- (prog2(setq ![er!] 1100)(return !!er!!))))
- (setq wa (car lst))
- (setq wb (cadr lst))
- (cond((or (cdr wa) (cdr wb) (not(idp(car wa))) (not(idp(car wb))) )
- (prog2(setq ![er!] 1100)(return !!er!!))))
- (setq wa (car wa))
- (setq wb (car wb))
- (cond((or (and (not(flagp wa '!+fun)) (not(redgood!> wa)) )
- (and (not(flagp wb '!+fun)) (not(redgood!> wb)) ) )
- (prog2(setq ![er!] 1100)(return !!er!!))))
- (put wa 'inverse wb)
- (put wb 'inverse wa)
- (return t)))
- %----- Order, Factor, RemFac commands -----------------------------------
- (de orfare!> (lst wt)
- (proc nil
- (cond((null lst)(return nil)))
- (setq lst(memlist!> '!, lst))
- (cond((eq lst !!er!!)
- (prog2 (setq ![er!] 2202) (return !!er!!))))
- (setq lst (mapcar lst 'translata!>))
- (cond((memq !!er!! lst) (return !!er!!)))
- (apply wt (list lst))))
- %----- Substitutions calls -----------------------------------------------
- (de smatch!> nil 'match)
- (de famatch!> nil
- (cond ((getd 'match00) 'match00)
- (t 'match ) ))
- (de slet!> nil
- (cond ((and (getd '!~let) (not(iscsl!>))) '!~let)
- (t 'let ) ))
- (de falet!> nil
- (cond ((getd 'let00) 'let00)
- ((and (getd '!~let) (not(iscsl!>))) '!~let)
- (t 'let ) ))
- (de sclear!> nil
- (cond ((and (getd '!~clear) (not(iscsl!>))) '!~clear)
- (t 'clear ) ))
- (de faclear!> nil
- (cond ((and (getd '!~clear) (not(iscsl!>))) '!~clear)
- (t 'clear ) ))
- %----- Clear ; command --------------------------------------------------
- (de cleri!> (lst wt) % wt=t clear wt=nil for all clear
- (proc (w wa wss)
- (cond ((null lst) (return nil)))
- (setq lst (memlist!> '!, lst))
- (cond ((eq lst !!er!!)
- (prog2 (setq ![er!] 2202) (return !!er!!))))
- (while!> lst
- (setq wa (translata!>(car lst)))
- (cond((eq wa !!er!!) (return !!er!!))
- ((null wa)(prog2(setq ![er!] 8710)(return !!er!!))) )
- (setq w (cons wa w))
- (setq lst (cdr lst)))
- (setq w (reverse w))
- (cond ((null wt) % this is for all case returning (clear w)
- (return (list (faclear!>) (list 'quote w)))))
- (eval (list (sclear!>) (list 'quote w))) % making (clear w)
- (while!> w % remembering
- (setq wss (list (sclear!>) (ncons(car w))))
- (setq ![sublist!] (delete wss ![sublist!]))
- (setq w (cdr w)))
- (return t)))
- %----- Let ; and Match ; commands ---------------------------------------
- (de leti!> (lst wt) (letmatchi!> lst wt t))
- (de matchi!> (lst wt) (letmatchi!> lst wt nil))
- % WW=T - Let, WW=NIL - Match
- % WT=T - Execute (Let/Match command), WT=NIL - Form (For All command)
- (de letmatchi!> (lst wt ww)
- (proc (w wa wl wr wss)
- (cond ((null lst) (return nil)))
- (setq lst (memlist!> '!, lst))
- (cond((eq lst !!er!!)
- (prog2 (setq ![er!] 2202) (return !!er!!))))
- (while!> lst
- (setq wa (seek1!> (car lst) '!=))
- (cond
- ((null wa)(progn
- (cond((not(eq (caar lst) '!S!o!l))
- (prog2(setq ![er!] 8709)(return !!er!!))))
- (setq wa (soltra!>(car lst)))
- (cond((eq wa !!er!!)(return !!er!!)))
- (setq w (cons wa w))))
- ((or(null(car wa))(null(cdr wa)))
- (prog2(setq ![er!] 8709)(return !!er!!)))
- (t(progn
- (setq wl (translata!>(reverse(car wa))))
- (setq wr (translate!>(cdr wa)))
- (cond((or(eq wl !!er!!)(eq wr !!er!!)) (return !!er!!))
- ((null wl) (prog2(setq ![er!] 8710)(return !!er!!)))
- ((and wr(not(zerop(car wr))))
- (prog2(setq ![er!] 8711)(return !!er!!))))
- (setq w (cons (list 'equal wl (cond(wr(cdr wr))(t 0))) w)))))
- (setq lst (cdr lst)))
- (setq w (reverse w))
- (cond((null wt) % for all case - returning
- (return (list (cond (ww (falet!>)) (t (famatch!>)))
- (list 'quote w)))))
- % let/match case - executing
- (cond (ww (eval (list (slet!>) (list 'quote w))))
- (t (eval (list (smatch!>) (list 'quote w)))))
- (while!> w % remembering
- (setq wss (list (sclear!>) (ncons(cadar w))))
- (setq ![sublist!] (cons wss (delete wss ![sublist!])))
- (setq w (cdr w)))
- (return t)))
- % Solution Translation ...
- (de soltra!> (w)
- (cond((or (null(setq w (cdr w))) (cdr w)
- (atom(setq w (car w)))
- (not(numberp(setq w (car w)))) )
- (progn (doub!> '!S!o!l) (setq ![er!] 2020) !!er!!))
- (t(soltra1!> w))))
- (de soltra1!> (wn)
- (cond((null ![sol!]) (prog2 (setq ![er!] 2113) !!er!!))
- (t(proc (w wnn)
- (setq wnn wn)
- (setq w ![sol!])
- (while!> (and w (not(zerop wn)))
- (setq w (cdr w))
- (setq wn (sub1 wn)))
- (cond
- ((or(null w)(not(zerop wn)))
- (progn(doub!> wnn)(setq ![er!] 2114)(return !!er!!)))
- ((null(car w))
- (progn(setq ![er!] 2115)(return !!er!!))))
- (return(mapcar (car w) 'nz!>))))))
- %----- For ...; commands ------------------------------------------------
- (de forinstrs!> (lst)
- (cond
- ((null lst) nil)
- ((eqs!> (car lst) 'all) (foralli!> (cdr lst))) % word!!! for all ...
- ((memqs!> 'print lst) (proc (w) % word!!! for...print...
- (while!> (not(eqs!> (car lst) 'print)) % word!!!
- (setq w (cons(car lst)w))(setq lst(cdr lst)))
- (cond((null(cdr lst))
- (prog2(setq ![er!] 6042)(return !!er!!))))
- (return(printi!>(append (cdr lst)
- (cons 'for % word!!!
- (reverse w)))))))
- (t(prog2(setq ![er!] 6042) !!er!!))))
- %----- For All...; command ----------------------------------------------
- (de foralli!> (lst)
- (proc (w wt wa wss w1 w2 w3)
- (cond((null lst)(return nil))
- ((memqs!> 'let lst)(setq wt 'let)) % word!!!
- ((memqs!> 'match lst)(setq wt 'match)) % word!!!
- ((memqs!> 'clear lst)(setq wt 'clear)) % word!!!
- (t(prog2(setq ![er!] 8712)(return !!er!!))))
- (while!> lst
- (exitif (eqs!> wt (car lst)))
- (setq wa(cons(car lst)wa))
- (setq lst(cdr lst)))
- (cond((or(null lst)(null(cdr lst))(null wa))
- (prog2(setq ![er!] 8713)(return !!er!!))))
- (setq lst (cdr lst))
- (cond((memqs!> 'such wa)(progn % word!!!
- (setq wa (reverse wa))
- (setq w3 (seek1q!> wa 'such)) % word!!!
- (cond((or (null(car w3)) (null(cdr w3)) (null(cddr w3))
- (not(eqs!> (cadr w3) 'that))) % word!!!
- (prog2(setq ![er!] 8712)(return !!er!!))))
- (setq wa (car w3))
- (setq w3 (cddr w3)) )))
- (setq wa(memlist!> '!, wa))
- (cond((eq wa !!er!!)
- (prog2 (setq ![er!] 2202) (return !!er!!))))
- (while!> wa
- (cond((or(cdar wa)(not(idp(caar wa))))
- (prog2 (setq ![er!] 8714) (return !!er!!))))
- (setq w (cons(caar wa)w))
- (setq wa (cdr wa)))
- (setq w1 w)
- (while!> w1
- (cond((not(flagp (car w1) '!+grgvar))
- (setq w2 (cons(car w1)w2))))
- (setq w1 (cdr w1)))
- (flag w '!+grgvar)
- (cond((null w3)(setq w3 t))
- (t(progn
- (setq w3 (booltra!> w3))
- (cond((eq w3 !!er!!)(return !!er!!))))))
- (setq wa
- (cond((eq wt 'let) (leti!> lst nil)) % not words
- ((eq wt 'match) (matchi!> lst nil)) % not words
- (t (cleri!> lst nil))))
- (cond((eq wa !!er!!)
- (prog2(remflag w2 '!+grgvar)(return !!er!!))))
- (errorset (list 'forall (list 'quote (list w w3 wa)))
- ![erst1!] ![erst2!] )
- (remflag w2 '!+grgvar)
- (setq wa (cadadr wa))
- (cond((not(eqs!> wt 'clear)) (setq wa (mapcar wa 'cadr)))) % not word
- (while!> wa
- (setq wss (list 'forall
- (list w w3
- (list (faclear!>)
- (list 'quote (ncons(car wa)))))))
- (setq ![sublist!] (delete wss ![sublist!]))
- (cond((not(eq wt 'clear)) % not word
- (setq ![sublist!] (cons wss ![sublist!]))))
- (setq wa (cdr wa)))
- (return t)))
- %----- Print...; command ------------------------------------------------
- (de printi!> (lst)
- (prog (wi)
- (cond ((null lst) (return nil)))
- (setq ![modp!] ![umod!])
- (cond ((not(and (fancyon!>) (not !*latex))) (terpri)))
- (cond ((memqs!> 'for lst) (progn % word!!!
- (setq lst (seek1q!> lst 'for)) % word!!!
- (setq wi (cdr lst))
- (setq lst (reverse(car lst))))))
- (cond ((null lst) (return nil)))
- (cond(wi(setq wi (memlist!> '!, wi))))
- (cond((eq wi !!er!!)(prog2(setq ![er!] 2202)(return wi))))
- (cond(wi(setq wi (itercon!> wi))))
- (cond((eq wi !!er!!)(prog2(setq ![er!] 21031)(return wi))))
- (setq ![allzero!] t)
- (setq ![extvar!] (mapcar wi 'caar))
- % This with prohibited unknown vars -> for
- % (setq lst (pretrans!> lst)) % Pre Translation ...
- % This with allowed unknown vars -> for
- (setq lst (pretransext!> lst)) % pre translation ...
- (cond ((and ![extvara!] !*nofreevars)
- (mapcar ![extvara!] 'doub!>)
- (setq ![er!] 2018)
- (setq ![extvara!] nil)
- (return !!er!!))
- ((and ![extvara!]
- (not(and (eqn (length ![extvara!]) 1)
- (equal (list 'dummyvar!> (car ![extvara!])) lst))))
- (setq wi (mapcar ![extvara!] 'ncons))
- (setq wi (mapcar wi 'ncons))
- (setq ![extvar!] ![extvara!])
- (setq ![extvara!] nil) ))
- (cond ((eq lst !!er!!) (return !!er!!)))
- (setq lst (printico!> wi nil lst nil))
- (cond((eq lst !!er!!)(return !!er!!)))
- (cond
- (![allzero!]
- (progn (alpri!> nil)
- (grgend!>)
- (grgterpri!>) (terpri)))
- ((and (not !*latex) (fancyon!>)) (terpri)))
- (return t)))
- (de appendn!> (wa wd)
- (cond((null wa) wd)
- (t(cons(ncons(car wa))(appendn!>(cdr wa)wd)))))
- (de printico!> (wi wt lst wp)
- (cond
- ((null wi) (progn
- (setq lst (fintrans!> lst)) % final translation
- (cond((eq lst !!er!!) !!er!!)
- ((null lst) nil)
- (t(progn (setq ![allzero!] nil)
- (cond(wt(prinvarl!>(reverse wt))))
- (cond(!*math(gprin!> "(")))
- (cond
- ((zerop(car lst)) (alpri!> (cdr lst))) % algexpr
- (t (dfpri!> (cdr lst) (car lst)))) % form
- (cond(!*math(gprin!> ")")))
- (cond((ifmodo!>)(ooend!>)))
- (grgterpri!>)
- (cond((not(and (fancyon!>) (not !*latex))) (terpri)))
- )))))
- (t(proc (wa we)
- (setq wa (errorset!> (list3 'itertr!> (list2 'quote (car wi))
- (list2 'quote wp) )
- ![erst1!] ![erst2!]))
- (cond((atom wa)(prog2(setq ![er!] wa)(return !!er!!)))
- (t(setq wa(reverse(car wa)))))
- (while!> wa
- (put (caar wa) '!=subind (cdar wa))
- (setq we (printico!> (cdr wi) (cons(cdar wa)wt) lst (cdar wa)))
- (remprop (caar wa) '!=subind)
- (cond((eq we !!er!!)(return we)))
- (setq wa (cdr wa)))))))
- (de prinvarl!> (w)
- (proc (wr we)
- (cond (!*math (setq wr '( !(!* )))
- (!*macsyma (setq wr '( !/!* )))
- (!*maple (setq wr '( !#! )))
- ((or !*grg !*reduce) (setq wr '( !% ))))
- (setq we ![extvar!])
- (while!> w
- (setq wr (cons(car w)(cons '!= (cons(car we)wr))))
- (setq w (cdr w))
- (cond((and w (fancyon!>)) (setq wr (cons '!, wr))))
- (setq we (cdr we)))
- (setq wr (cons
- (cond (!*math '!*!) )
- (!*macsyma '!*!/ )
- (!*grg '!;! )
- ((fancyon!>) '!: )
- % ((fancyon!>) '!:!\! )
- (t '!:! )) wr))
- (setq wr (reverse wr))
- (cond((ifmodo!>) (prog2(gprinwb!> wr)(gterpri!>)))
- (t (algprinwb!> wr)))
- (cond ((fancyon!>) (algpri!> " ")))
- ))
- (de itercon!> (lst)
- (proc (w wc)
- (while!> lst
- (setq wc (car lst))
- (setq lst (cdr lst))
- (cond((or(memq '!< wc)(memq '!> wc)(memq '!<!= wc)(memq '!>!= wc))
- (progn (setq wc (itercon1!> wc))
- (cond((eq wc !!er!!)(return !!er!!)))
- (setq w (append wc w)) ))
- (t(setq w (cons(ncons wc)w)))))
- (return(reversip w))))
- (de itercon1!> (lst)
- (proc (w wc wa)
- (while!> lst
- (cond
- ((memq (car lst) '(!< !> !<!= !>!=))
- (cond((or(null(cdr lst))(null wa))(return !!er!!))
- (t(progn (setq w (cons (cons(reverse wa)wc) w))
- (setq wa nil)
- (setq wc (itcty!>(car lst)))
- (setq lst (cdr lst)) ))))
- (t(prog2(setq wa (cons(car lst)wa))
- (setq lst (cdr lst))))))
- (setq w (cons (cons(reverse wa)wc) w))
- (return w)))
- (de itcty!> (w)
- (cond
- ((eq w '!<) 1)
- ((eq w '!>) 2)
- ((eq w '!<!=) 3)
- ((eq w '!>!=) 4)))
- %----- Comment ... command -----------------------------------------------
- (de comment!> (lst)
- (cond (![unl!] (progn
- (wrs ![unl!])
- (print '(cout!>)) (terpri)
- (print (list 'comin!> (list 'quote lst))) (terpri)
- (wrs ![wri!]) ))
- (t nil)))
- %----- Zero/Nullify command ----------------------------------------------
- (de zero!> (lst) % 05.96
- (proc (w wc)
- (cond ((null lst) (return nil))
- ((eqs!> lst '(time)) (progn % word!!!
- (setq ![time!] (time))
- (setq ![gctime!] (gctime))
- (return nil))))
- (cond ((eq (setq w (dgood!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (setq wc (car w))
- (cond ((not (memq wc '(![cord!] ![const!] ![fun!] ![sol!] ![apar!] )))
- (cond
- ((eq wc '!#!G) (setq ![mtype!] 3) (setq ![dtype!] 1) )
- ((eq wc '!#!G!I) (setq ![mitype!] 3) (setq ![ditype!] 1) )
- ((eq wc '!#!T) (setq ![ftype!] 3) )
- ((eq wc '!#!D) (setq ![fitype!] 3) ) )
- (set wc (mkbox!> wc))))
- (setq w (cdr w)))))
- %----- Forget ; command --------------------------------------------------
- (de forget!> (lst)
- (proc (w)
- (cond ((null lst) (return nil))
- ((eq (setq w (dgood!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (cond ((flagp (car w) '!+abbr) (forget1!>(car w)))
- (t (msg!> 8701)))
- (setq w (cdr w)))))
- (de forget1!> (w)
- (prog (wa wb wl)
- (cond
- ((flagp w '!+abbr) (prog2
- (setq wb ![abbr!])
- (setq ![abbr!]
- (loop!>
- (cond ((eq w (car wb)) (return (app!> wa (cdr wb))))
- (t(prog2 (setq wa (cons (car wb) wa))
- (setq wb (cdr wb))))))))))
- % (setplist w nil) % AMI: removes ALL properties and flags
- (remprop w 'vartype) % PSL: removes GLOBAL/FLUID
- (setq wl (ncons w))
- (set w nil)
- (foreach!> x in ![allflags!] do (remflag wl x))
- (foreach!> x in ![allprops!] do (remprop w x))
- ))
- %-------- Hold/Relese; ---------------------------------------------------
- (de hold!> (lst wt)
- (prog (w)
- (cond ((null lst) (return nil))
- ((eq (setq w (dgood!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (cond (wt (flag w '!+hold))
- (t (remflag w '!+hold)))
- (return t)))
- %---------- Erase/Delete; -----------------------------------------------
- (de erase!> (lst) % 5.96
- (proc (w wc)
- (cond ((null lst) (return nil))
- ((eq (setq w (dgood!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (setq wc (car w))
- (cond ((and ![umod!] (memq wc '(!#!b !#!e))) (msg!> 7012))
- ((eq wc '![cord!])
- (rempf!> ![rpflcr!] nil) (setq ![cord!] nil))
- ((eq wc '![const!])
- (rempf!> ![rpflcn!] nil) (setq ![const!] nil))
- ((eq wc '![apar!])
- (rempf!> ![rpflap!] '(2)) (setq ![apar!] nil))
- ((eq wc '![fun!])
- (rempf!> ![rpflfu!] '(1)) (setq ![fun!] nil)
- (setq ![gfun!] nil) )
- (t (set wc nil)))
- (cond
- ((eq wc '!#!G) (setq ![mtype!] nil) (setq ![dtype!] nil) )
- ((eq wc '!#!G!I) (setq ![mitype!] nil) (setq ![ditype!] nil) )
- ((eq wc '!#!T) (setq ![ftype!] nil) )
- ((eq wc '!#!D) (setq ![fitype!] nil) ) )
- (setq w (cdr w)) )
- (return t)))
- %----- New Commands Driver -----------------------------------------------
- (de newcommands!> (w)
- (cond ((null w) nil)
- ((eqs!> (car w) 'coordinates) (chcoord!> (cdr w))) % word!!!
- ((eqs!> (car w) 'object) (obdec!> (cdr w) 0)) % word!!!
- ((eqs!> (car w) 'equation) (obdec!> (cdr w) 1)) % word!!!
- ((eqs!> (car w) 'connection) (obdec!> (cdr w) 2)) % word!!!
- (t (obdec!> w 0))))
- %----- Show Commands Driver ----------------------------------------------
- (de shcommands!> (w)
- (cond ((null w) nil)
- ((eqs!> w '(time)) (timei!>)) % word!!!
- ((eqs!> w '(status)) (shstatus!>)) % word!!!
- ((eqs!> w '(all)) (shall!>)) % word!!!
- ((eqs!> w '(gc time)) (gctime!>)) % word!!!
- ((eqs!> (car w) 'switch) (sflag!> (cdr w))) % word!!!
- ((eqs!> (car w) 'file) (showfil!> (cdr w))) % word!!!
- ((memq '!* w) (shallbuilt!> w))
- ((stringp (car w)) (showfil!> w))
- ((and (null(cdr w)) (idp(car w))
- (or (flagp (idtostcase!> (car w)) 'switch)
- (flagp (idtostcase!> (car w)) '!+switch)))
- (sflag!> w))
- (t (showobj!> w))))
- %----- Show Object -------------------------------------------------------
- (de showobj!> (lst)
- (proc (w)
- (cond ((null lst) (return nil))
- ((eq (setq w (dgoodw!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (cond ((null w) (return nil)))
- (while!> w
- (cond ((memq (car w) '(![cord!] ![const!] ![fun!] ![sol!] ![apar!]))
- nil )
- (t (shobj1!> (car w))))
- (setq w (cdr w)) )
- (terpri)
- (return t)))
- (de shobj1!> (w)
- (prog (wi wt wy ww wc wd wx)
- (terpri)
- (setq wi (get w '!=idxl))
- (setq wt (gettype!> w))
- (setq wy (get w '!=sidxl))
- (setq ww (get w '!=way))
- (setq wd (get w '!=dens))
- (gprinreset!>)
- (setq ![gptab!] 2)
- % Name ...
- (cond ((not(or (flagp w '!+abbr) (flagp w '!+macros2))) (thepn!> w)))
- % ID ...
- (gprin!> (incom!>(cdr(explode2 w))))
- % Indices ...
- (while!> wi
- (setq wc (car wi))
- % Position ...
- (cond
- ((and (upperp!> wc) (holp!> wc)) (gprin!> "^"))
- ((upperp!> wc) (gprin!> "'"))
- ((holp!> wc) (gprin!> "_"))
- (t (gprin!> ".")))
- % Type ...
- (cond
- ((holp!> wc) (gprin!>(car ![wh!])) (setq ![wh!] (cdr ![wh!])))
- ((tetrp!> wc) (gprin!>(car ![wf!])) (setq ![wf!] (cdr ![wf!])))
- ((enump!> wc) (gprin!>(car ![wi!])) (setq ![wi!] (cdr ![wi!]))
- (cond ((cdr wc) (gprin!> (cdr wc)))
- (t (gprin!> "dim"))))
- ((spinp!> wc) (for!> x (1 1 (cdr wc)) do (progn
- (gprin!>(car ![ws!]))
- (setq ![ws!] (cdr ![ws!]))))))
- (cond ((dotp!> wc) (gprin!> "~")))
- (setq wi (cdr wi)))
- (gpris!>)
- % Type ...
- (gprin!> (cond((flagp w '!+pl) "are")(t "is")))
- (gpris!>)
- (cond ((eqn wt -1) (gprin!> "Vector"))
- ((eqn wt 0) (gprin!> "Scalar"))
- (t (gprin!> wt) (gprin!> "-form")))
- (cond ((flagp w '!+equ) (gpris!>) (gprin!> "Equation"))
- ((flagp w '!+fconn) (gpris!>)
- (gprils0!> '("Frame" "Connection")))
- ((flagp w '!+hconn) (gpris!>)
- (gprils0!> '("Holonomic" "Connection")))
- ((flagp w '!+uconn) (gpris!>)
- (gprils0!> '("Spinor" "Connection")))
- ((flagp w '!+dconn) (gpris!>)
- (gprils0!> '("Conjugate" "Spinor" "Connection")))
- ((flagp w '!+macros2) (gpris!>)
- (gprils0!> '("Macro" "Object")))
- (wd (gpris!>)
- (gprin!> "Density")
- (gpris!>)
- (cond ((car wd) (gprin!> "sgnD") (setq wx t)))
- (cond ((cadr wd) (cond (wx (gprin!> "*")))
- (setq wx t)
- (gprin!> "D")
- (cond ((not(eqn (cadr wd) 1))
- (gprin!> "^")
- (cond ((lessp (cadr wd) 0) (gprin!> "(")))
- (gprin!> (cadr wd))
- (cond ((lessp (cadr wd) 0) (gprin!> ")")))
- ))))
- (cond ((caddr wd) (cond (wx (gprin!> "*")))
- (setq wx t)
- (gprin!> "sgnL")))
- (cond ((cadddr wd) (cond (wx (gprin!> "*")))
- (gprin!> "L")
- (cond ((not(eqn (cadddr wd) 1))
- (gprin!> "^")
- (cond ((lessp (cadddr wd) 0) (gprin!> "(")))
- (gprin!> (cadddr wd))
- (cond ((lessp (cadddr wd) 0) (gprin!> ")")))
- ))))
- ))
- (gterpri!>)
- % Value ...
- (cond ((flagp w '!+macros2) nil)
- ((eval w) (gprin!> "Value: known") (gterpri!>))
- (t (gprin!> "Value: unknown") (gterpri!>)))
- % Symmetries ...
- (cond((null wy) (go lab1)))
- (gprinreset!>) (gprin!> " ")
- (setq ![gptab!] 4)
- (gprin!> "Symmetries:")
- (gpris!>)
- (while!> wy
- (shsy!>(car wy))
- (cond((cdr wy) (prog2 (gprin!> ",") (gpris!>))))
- (setq wy (cdr wy)))
- (gterpri!>)
- lab1
- % Ways of calculation ...
- (setq ww (allways!> ww))
- (cond ((null ww) (go lab2)))
- (gprinreset!>) (gprin!> " ")
- (setq ![gptab!] 4)
- (gprin!> "Ways of calculation:")
- (gterpri!>)
- (while!> ww
- (gprinreset!>)
- (setq ![gptab!] 6)
- (gprin!> " ")
- (setq wc (car ww))
- (gprils!> (lowertxt!>(car wc)))
- (setq wc (cdr wc))
- (gprin!> "(")
- (while!> wc
- (gprin!> (incom!> (cdr (explode2
- (cond ((pairp(car wc)) (cadar wc)) (t (car wc))) ))))
- (cond((pairp(car wc)) (gprin!> "*")))
- (cond ((cdr wc) (gprin!> ",")))
- (setq wc (cdr wc)))
- (gprin!> ")")
- (gterpri!>)
- (setq ww (cdr ww)))
- lab2
- (gprinreset!>)))
- (de shsy!> (w)
- (cond ((numberp w) (gprin!> w))
- ((idp w) (gprin!> (tolc!> w)))
- ((idp(car w)) (prog2 (shsy!>(car w)) (shsy!>(cdr w))))
- (t(proc nil
- (gprin!> "(")
- (while!> w
- (shsy!> (car w))
- (cond((cdr w) (gprin!> ",")))
- (setq w (cdr w)))
- (gprin!> ")") ))))
- (de allways!> (ww)
- (proc (wr w)
- (while!> ww
- (cond((not(eval(cadar ww))) (setq wr (cons (car ww) wr))))
- (setq ww (cdr ww)))
- (setq ww nil)
- (while!> wr
- (setq w (needdata!>(cdddar wr)))
- (setq w
- (cons (cond((null(caar wr)) '( "Standard way" )) (t(caar wr))) w))
- (setq ww (cons w ww))
- (setq wr (cdr wr)))
- (return ww)))
- (de needdata!> (w)
- (cond ((null w) nil)
- ((atom (car w)) (cons (car w) (needdata!> (cdr w))))
- ((eq (caar w) t) (cons (car w) (needdata!> (cdr w))))
- ((eval (caar w)) (append (cdar w) (needdata!> (cdr w))))
- (t (needdata!> (cdr w)))))
- %----- Time; and GC Time; commands ---------------------------------------
- (de timei!> nil
- (prog (wt wgt)
- (setq wt (difference (time) ![time!]))
- (setq wgt (difference (gctime) ![gctime!]))
- (cond ((iscsl!>) (setq wt (plus wt wgt))))
- (cond ((not(eqn wt 0)) (setq wgt (quotient (times 100 wgt) wt)))
- (t (setq wgt 0)))
- (prin2 "Time: ")
- (prtime!> wt)
- (cond ((zerop wt) (prog2 (terpri) (return nil))))
- (prin2 " (")
- (prin2 wgt)
- (prin2 "%GC)")
- (terpri)))
- (de gptime!> nil
- (prog (wt wgt)
- (setq wt (difference (time) ![time!]))
- (cond ((iscsl!>) (setq wgt (difference (gctime) ![gctime!]))
- (setq wt (plus wt wgt))))
- (gprtime!> wt)
- (gterpri!>)))
- (de gctime!> nil
- (progn (prin2 "Garbage collections time: ")
- (prtime!> (difference (gctime) ![gctime!])) (terpri)))
- (de prtime!> (w)
- (prog (wa wb)
- (setq wb (quotient (remainder w 1000) 10))
- (setq wa (quotient w 1000))
- (prin2 wa)(prin2 ".")
- (cond((lessp wb 10)(prin2 "0")))
- (prin2 wb)
- (prin2 " sec")))
- (de gprtime!> (w)
- (prog (wa wb wt)
- (setq wb (quotient (remainder w 1000) 10))
- (setq wa (quotient w 1000))
- % (gprin!> wa)(gprin!> ".")
- % (cond((lessp wb 10)(gprin!> "0")))
- % (gprin!> wb)
- % (gprin!> " sec")
- (setq wt '(! !s !e !c !"))
- (setq wt (append (explode2 wb) wt))
- (cond((lessp wb 10) (setq wt (cons '!0 wt))))
- (setq wt (cons '!. wt))
- (setq wt (append (explode2 wa) wt))
- (setq wt (cons '!" wt))
- (gprin!>(compress wt))
- ))
- %----- Find/Calculate ; command ------------------------------------------
- (de find!> (lst)
- (proc (w wa wss)
- (cond ((null lst) (return nil)))
- (setq w (byfrom!> lst))
- (cond ((eq w !!er!!) (return !!er!!)))
- (setq wss w)
- (cond ((eq(setq w (dgoodw!> w)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (cond
- ((flagp (car w) '!+macros2)
- (doubo!>(car w)) (msg!> 100) (setq w (cdr w)))
- ((null(eval(car w))) (progn
- (setq ![chain!] nil)
- (setq wa (request!>(car w)))
- (cond((eq wa !!er!!)
- (prog2(trsf!>(car w))(return !!er!!)))
- ((null wa)
- (progn(setq ![er!] 6046)(trsf!>(car w))(return !!er!!))))
- (setq w (cdr w))))
- (t (aexp!>(car w)) (setq w (cdr w)))))
- (return t)))
- % Way extraction ...
- (de byfrom!>(w)
- (proc(wa) (setq ![way!] nil)
- (while!>(and w (not(bftp!>(car w))))
- (prog2(setq wa(cons(car w)wa))(setq w(cdr w))))
- (cond((or(null wa)(and w(null(cdr w))))
- (progn(setq ![er!] 6042)(return !!er!!)))
- (w(prog2(setq ![way!] w)(return(reverse wa))))
- (t(prog2(setq ![way!] nil)(return(reverse wa)))))))
- %---------- Write ...; command -------------------------------------------
- (de write!> (lst)
- (proc (w wa wc)
- (cond ((null lst) (return nil)))
- (setq w (tofile!> lst 'write))
- (cond((eq w !!er!!) (return !!er!!))
- ((null w) % here ends global write to...; command
- (progn (closewrite!>) % close old global file ..
- (setq ![wri!] ![lwri!])
- (setq ![lwri!] nil)
- (wrs ![wri!])
- (return t)))
- (t(progn (setq wc (cdr w)) (setq w (car w))))) % wc=t write...to...;
- (cond((eq (setq w (dgoodw!> w)) !!er!!)
- (progn (cond(wc(closelw!>)))
- (return !!er!!))))
- (cond (wc(wrs ![lwri!])))
- (setq w (altdata!> w))
- (while!> w
- (cond((memq (car w) '(!#!b !#!e)) (setq ![modp!] nil))
- (t (setq ![modp!] ![umod!])))
- (setq wa (dtl!> (car w)))
- (cond((eq wa !!er!!) (progn (cond(wc(closelw!>)))
- (return !!er!!))))
- (setq w(cdr w)))
- (cond (wc(closelw!>))) % closing if it is write..to...; command
- (return t)))
- (de closelw!> nil
- (progn (close ![lwri!])
- (setq ![lwri!] nil)
- (wrs ![wri!]) ))
- % Write ; commands for different data types 27.12.90
- % General write: if =DATL call special function otherwise Standard ...
- (de dtl!> (w)
- (cond ((get w '!=datl) (apply 'eval (get w '!=datl)))
- (t (datlt!> w))))
- % The Standard form of Write command ...
- (de datlt!> (wn)
- (proc (lst w)
- (cond ((flagp wn '!+macros2) (setq lst (prepmac!> wn)))
- (t (setq lst (eval wn))))
- (cond ((null lst) (prog2 (abse!> wn) (return nil))))
- (gprinreset!>) (thepn0!> wn) (gprin!> ":") (gterpri!>)
- (cond % write as a matrix ...
- ((and !*wmatr (not(ifmodo!>))
- (zerop(gettype!> wn))
- (eqn (length(get wn '!=idxl)) 2))
- (setq ![allzero!] nil)
- (alpri!>(cons 'mat lst))
- (algterpri!>)
- (go lab)))
- (cond ((not(and (fancyon!>) (not !*latex))) (terpri)))
- (setq ![idwri!] (incom!>(cdr(explode2 wn))))
- (setq ![allzero!] t)
- (allcom!> lst wn nil (cond ((setq w (get wn '!=idxl)) w)
- (t '(0)))
- (function printco!>))
- lab
- (cond
- (![allzero!]
- (progn (cond ((flagp wn '!+equ) (eqpri!> nil nil 0))
- (t (alpri!> nil)))
- (grgend!>)
- (grgterpri!>) (terpri)))
- ((and (not !*latex) (fancyon!>)) (terpri)))
- ))
- % Prepare values for Macro tensor ...
- (de prepmac!> (wn)
- (prog (wr)
- (setq wr (errorset (list 'require!> (list 'quote (get wn '!=ndl))
- nil nil)))
- (cond ((atom wr) (return nil)))
- (setq wr (mkbox!> wn))
- (setq wr (allcoll!> wr wn nil
- (cond((get wn '!=idxl) (get wn '!=idxl))
- (t '(0)))
- (function prepmac0!>)))
- (return wr)))
- (de prepmac0!> (w wi wn)
- (cond ((syaidxp!> wi (get wn '!=sidxl))
- (setq w (eval (cons (get wn '!=evf) wi)))
- (cond ((eqn (gettype!> wn) 0) (evalalg!> w))
- (t (evalform!> w))))
- (t nil)))
- % One component printing ...
- (de printco!> (we wi wn)
- (prog (wq)
- (cond((null we)(return nil)))
- (setq ![allzero!] nil)
- (setq wq (flagp wn '!+equ)) % equation
- (idwri!> wn wi) % write identifier
- (wriassign!> wq) % write =
- (prel!> we (gettype!> wn) wq) % write value
- (grgends!>)
- (grgterpri!>)
- (cond((not(and (fancyon!>) (not !*latex))) (terpri)))
- ))
- (de idwri!> (wn wi)
- (cond
- ((fancyon!>) (prog (wa w ww wc wss)
- (setq wc 0)
- (cond
- ((setq wa (get wn '!=idxl))
- (setq wss (needspace!> wa)) % we need extra space between indices?
- (foreach!> x in wi do
- (progn
- (setq wc (add1 wc))
- % index ...
- (cond
- ((holonomq1!>(car wa))
- (setq w (getel1!> ![cord!] x)))
- (t (setq w '( !" ))
- (cond ((dotp!>(car wa))
- (setq w (cons (cond (!*latex '!}) (t '!')) w))))
- (setq w (append (explode2 x) w))
- (cond ((and (dotp!>(car wa)) !*latex)
- (setq w (append '(!\ !d !o !t !{) w))))
- (setq w (cons '!" w))
- (setq w (compress w))))
- % place to put index ...
- (cond((eqn wc 1) (setq ww (fancyidwri!> wn)))
- (t (setq ww '!#!#lr)))
- (cond ((and wss (not(eqn wc 1))) (algpri!> "\,")))
- (cond
- ((or (upperp!>(car wa)) (eq wn '!#b))
- (algpri!> (list 'expt ww w) ))
- (t(progn
- (flag (ncons ww) 'print!-indexed)
- (algpri!> (list ww w) )
- (remflag (ncons ww) 'print!-indexed))))
- (setq wa (cdr wa)))))
- (t (algpri!> (fancyidwri!> wn) )) )))
- ((ifmodo!>) (ooelem!> ![idwri!] wi))
- (t(prog (wa wp wss wl wx)
- (algpri!> ![idwri!] )
- (cond((setq wa (get wn '!=idxl))
- (setq wss (needspace!> wa)) % we need extra space between indices?
- (foreach!> x in wi do
- (progn
- (setq wx
- (cond ((holonomq1!>(car wa)) (getel1!> ![cord!] x))
- (t x)))
- (cond (wss (algpri!> " "))) % extra space
- (cond (wss (setq wl (length(explode2 wx))))
- (t (setq wl 1)))
- % vertical position ...
- (setq wp (cond
- ((enump!>(car wa)) 0) % enum
- ((and (upperp!>(car wa)) (dotp!>(car wa))) % upper dot
- (setq ymax!* 2) 1)
- ((upperp!>(car wa)) % upper
- (setq ymax!* 1) 1)
- (t (setq ymin!* -1) -1))) % lower
- % drawing index itself ...
- (setq pline!* (cons
- (cons (cons (cons posn!* (plus wl posn!*))
- wp)
- wx)
- pline!*))
- % dot for dotted index ...
- (cond ((dotp!>(car wa))
- (setq pline!* (cons
- (cons (cons (cons posn!* (add1 posn!*))
- (add1 wp))
- ".")
- pline!*))))
- (setq posn!* (plus wl posn!*))
- (setq wa (cdr wa)) )))) ))))
- (de needspace!> (wi)
- (cond ((null wi) nil)
- ((holonomq1!>(car wi)) t)
- ((greaterp (dimid!>(car wi)) 9) t)
- (t (needspace!> (cdr wi)))))
- (de fancyidwri!> (wn)
- (prog (w)
- (setq w (get wn '!=tex))
- (cond
- (w(prog2
- (put wn 'fancy!-special!-symbol
- (cond ((and (pairp w) !*latex) (car w))
- ((pairp w) (cdr w))
- (t w)))
- (return wn)))
- (t(return ![idwri!])))))
- % Expression or Equality printing ...
- (de prel!> (we wt wq)
- (prog (wl wr)
- (cond(!*math(gprin!> "(")))
- (cond (wq (prog2
- (cond(we(prog2 (setq wl (cadr we))
- (setq wr (caddr we)))))
- (eqpri!> wl wr wt)))
- ((zerop wt) (alpri!> we))
- (t (dfpri!> we wt)))
- (cond(!*math(gprin!> ")"))) ))
- % Special write for Constant and Coordinates ...
- (de datlc!> (wa txt pl)
- (proc nil
- (cond((null wa)(progn(terpri)
- (prin2 txt)
- (cond (pl (prin2 " are absent."))
- (t (prin2 " is absent.")))
- (terpri)
- (return nil))))
- (prin2 txt)
- (prin2 ":")(terpri)(terpri)
- (gprinreset!>)
- (gprils0!> wa)
- (gterpri!>)(terpri)))
- % Special write for Functions ...
- (de funl!> nil
- (prog (w)
- (cond((null ![fun!])(progn
- (prin2 "Functions are absent.")(terpri)
- (return t))))
- (prin2 "Functions:")(terpri)(terpri)
- (gprinreset!>)
- (foreach!> x in ![fun!] do (progn
- (cond((setq w(get x '!=depend)) (gfnpri!> w))
- (t (gprin!> x)))
- (gprin!> '! )))
- (gterpri!>)(terpri)))
- % Special write for Solutions ...
- (de solwri!> nil
- (proc (w wn)
- (cond((null ![sol!])(progn
- (prin2 "Solutions are absent.")(terpri)
- (return t))))
- (prin2 "Solutions:")(terpri)
- (cond((not(and (fancyon!>) (not !*latex))) (terpri)))
- (setq w ![sol!])
- (setq wn 0)
- (while!> w
- (cond
- ((ifmodo!>) (ooelem!> '!S!o!l (ncons wn)))
- (t(progn
- (algpri!> "Sol(" )
- (algpri!> wn )
- (algpri!> ")" ) )))
- (wriassign!> t)
- (prel!> (car w) 0 t)
- (grgends!>)
- (grgterpri!>)
- (cond((not(and (fancyon!>) (not !*latex))) (terpri)))
- (setq wn (add1 wn))
- (setq w (cdr w)))
- (cond((and (fancyon!>) (not !*latex)) (terpri)))
- ))
- %---------- Output ...; command ------------------------------------------
- (de grgout!> (w) (write!> (cons '!> w)))
- %---------- In "..."; command ------------------------------------------
- (de from!> (lst)
- (proc (w wp)
- (cond ((null lst) (return nil))
- ((or(not(stringp(car lst))) (cdr lst))
- (prog2 (setq ![er!] 6301) (return !!er!!))))
- (setq w (grgopeninput!> (car lst)))
- (cond ((atom w) (prog2 (setq ![er!] 6321) (return !!er!!))))
- (setq w (car w))
- (rds w)
- (setq ![echo!] t)
- % (terpri)
- (setq wp (listok!> '( !$ )))
- (setq ![echo!] nil)
- % (terpri)
- (rds nil)
- (close w)
- (cond ((eq wp !!er!!) (return !!er!!)))
- (setq wp (collect!> wp))
- (cond ((eq wp !!er!!) (return !!er!!)))
- (setq wp (mapcar wp 'mklevel!>))
- (setq wp (mapcar wp 'car))
- % execute the commands ...
- (while!> wp
- (cond ((and (car wp) (eq (runcom!>(car wp)) !!stop!!))
- (return !!stop!!)))
- (setq wp (cdr wp)))
- (return t)))
- % Open file ...
- % WD - filename, WI - INPUT/OUTPUT, WB - UNLOAD/WRITE
- (de rdsio!> (wd wi wb)
- (prog (w wf)
- (cond((not(stringp wd))(prog2(setq ![er!] 6301)(return !!er!!))))
- (setq w (errorset (list 'open wd(list 'quote wi)) nil nil))
- (cond((atom w)(prog2(setq ![er!] 6321)(return !!er!!))))
- (cond
- % input file for load ...
- ((eq wi 'input)
- (prog2 (setq ![loa!] (car w)) (rds ![loa!])))
- % output file for write ...
- ((eq wb 'write) (setq ![lwri!] (car w)))
- % output file for unload ...
- ((eq wb 'unload) (setq ![lunl!] (car w)))
- )))
- %---------- Unload ...; command ------------------------------------------
- (de unl!> (lst)
- (proc (w wc wa)
- (cond ((null lst) (return nil)))
- (setq w (tofile!> lst 'unload))
- (cond((eq w !!er!!) (return !!er!!))
- ((null w) (progn % global unload file resetting and quit
- (closeunload!>)
- (setq ![unl!] ![lunl!])
- (setq ![lunl!] nil)
- (return t))) % here ends unload to...; command
- (t(progn (setq wc (cdr w)) (setq w (car w)))))
- (setq wa w)
- (cond((eq (setq w (dgood!> w)) !!er!!)
- (prog2 (cond(wc(closelu!>))) (return !!er!!))))
- (cond (wc (wrs ![lunl!])) (t(wrs ![unl!]))) % directing output ...
- (print '(cout!>)) (terpri)
- (print (list 'sgn!> (list 'quote ![sgn!]))) (terpri)
- (setq w (altdata!> w))
- (cond ((and ![umod!] (eqs!> wa '(all))) (progn % word!!!
- (print '(smt!>)) (terpri)
- (setq w (append '(![dbas!] ![xb!] ![xv!]
- ![xf!] ![ccb!] ![ccbi!]) w)))))
- (while!> w
- (cond ((and (eq (car w) '![cord!]) (null !*unlcord)) nil)
- ((get (car w) '!=unl)
- (apply 'eval (get (car w) '!=unl))
- (cond ((and (eq (car w) '![fun!]) ![gfun!])
- (print (list 'putgfun!> (list 'quote ![gfun!])))
- (terpri))))
- (t(progn
- (cond ((flagp (car w) '!+abbr) (unlnvar!>(car w))))
- (print (list 'setq (car w) (list 'quote (eval(car w)))))
- (terpri) )))
- (setq w (cdr w)))
- (print '(rout!>)) (terpri)
- (cond (wc (closelu!>)) (t (wrs ![wri!]))) % restoring output ...
- (return t)))
- (de closelu!> nil
- (progn (print t)
- (close ![lunl!])
- (setq ![lunl!] nil)
- (wrs ![wri!]) ))
- % Unload new-built data ...
- (de unlnvar!> (w)
- (proc (lst)
- (cond
- ((flagp w '!+abbr) (print (list 'pushabbr!> (list 'quote w)))
- (terpri) ))
- (setq lst ![allflags!])
- (while!> lst
- (unlflag!> w (car lst))
- (setq lst(cdr lst)))
- (setq lst ![allprops!])
- (while!> lst
- (unlprop!> w (car lst))
- (setq lst(cdr lst)))
- ))
- % Unloads flag ...
- (de unlflag!> (w wf)
- (cond ((flagp w wf)
- (print (list 'flag (list 'quote (list w)) (list 'quote wf)))
- (terpri) )))
- % Unloads prop ...
- (de unlprop!> (w wf)
- (prog (wa)
- (cond ((setq wa (get w wf))
- (print (list 'put (list 'quote w)
- (list 'quote wf)
- (list 'quote wa)))
- (terpri) ))))
- %---------- Load ...; command --------------------------------------------
- (de loa!> (lst)
- (proc (w wf we)
- (cond ((null lst) (return nil))
- ((eqs!> (car lst) 'package) % word!!!
- (return (loadpack!> (cdr lst) t)))
- ((not(stringp(car lst)))
- (return (loadpack!> lst t))))
- (setq wf t)
- (cond ((cdr lst) (prog2(setq ![er!] 6301)(return !!er!!))))
- (setq lst (rdsio!> (car lst) 'input nil))
- (cond ((eq lst !!er!!) (return !!er!!)))
- (loop!>
- (setq w (errorset '(read) nil nil))
- (cond ((atom w) % unexpected data
- (progn (cload!>) (setq ![er!] 7720) (return !!er!!)))
- ((or (equal w '(t))
- (equal w (ncons !$eof!$))
- (atom w)) % eof encountered
- (progn (cload!>) (copar!>) (return t)))
- ((and wf (not (equal w '((cout!>))))) % not .loa file format
- (progn (cload!>) (setq ![er!] 7200) (return !!er!!))))
- (setq we (errorset (car w) nil nil))
- (cond ((atom we) % unexpected data
- (progn (cload!>) (setq ![er!] 7720) (return !!er!!))))
- (setq wf nil))
- ))
- (de cload!> nil
- (progn
- (close ![loa!])
- (rds nil)
- (mtype!>)
- (mitype!>)
- (ftype!>)
- (fitype!>)
- ))
- % Basis changing with Load ...
- (de smt!> nil
- (prog2
- (setq ![umod!] t)
- (prin2 "Basis is anholonomic now.")
- (terpri)))
- % Dimension/Signature control with Load ...
- (de sgn!> (w)
- (cond
- ((not(equal w ![sgn!])) % signature diffres
- (cond
- (![firsti!] (setq ![sgn!] w)
- (setq ![dim!] (length w))
- (tunedim!>)
- (sdimsgn!>) )
- (t (erm!> 7900) (err!> 7900))))))
- % Load Comment ...
- (de comin!> (lst)
- (progn (gprinreset!>)
- (gprils0!> (cons "%" lst))
- (gprin!> ";")
- (gterpri!>)
- ))
- %----- Special Load/Unload for Fun, Cord and Const -----------------------
- (dm putpnu!> (u) (list 'putpnu0!> (list 'quote (cdr u))))
- (de putpnu0!> (u)
- (prog (w wc)
- (setq w '(putpn!>))
- (for!> x (0 1 1) do (progn (setq wc (eval(car u)))
- (setq u (cdr u))
- (setq w (cons (list 'quote wc) w))))
- (foreach!> x in u do (setq w (cons (list 'quote x) w)))
- (print(reverse w))
- (terpri) ))
- (de putgfun!> (w)
- (progn
- (loadpack!> '(dfpart) nil)
- (generic!_function w)
- (cond (!*dfpcommute (dfp!_commute w)))))
- (de putpn!> (wd w wf wp wss)
- (proc (wn wa)
- (cond((null w)(return nil)))
- (cond((and (eqn wss 1) !*unlcord)
- (progn (warcor!> w)
- (rempf!> ![rpflcr!] nil)
- (setq ![cord!] w)))
- ((eqn wss 1)(return nil))
- ((eqn wss 2)
- (prog2 (warcon!> w)
- (setq w(setq ![const!](appmem!> w ![const!])))))
- ((eqn wss 3)(progn
- (warfun!> w)
- (setq wa(newid!> w ![fun!]))
- (setq w(setq ![fun!](appmem!> w ![fun!])))
- (operator wa)))
- ((eqn wss 4) (setq ![apar!] w)
- (foreach!> x in ![cord!] do (depend (cons x w)))) )
- (while!> wf
- (flag w (car wf))
- (setq wf(cdr wf)))
- (setq wn 0)
- (while!> w
- (cond(wp(put (car w) wp wn)))
- (setq wn(add1 wn))
- (setq w(cdr w)))
- (cond(wd(foreach!> x in wd do (progn
- (depend x)
- (flag (ncons(car x)) '!+grgvar)
- (put (car x) '!=depend x) ))))
- ))
- (de putfndp!> nil
- (prog (w wa)
- (foreach!> x in ![fun!] do
- (cond((setq wa(get x '!=depend))(setq w(cons wa w)))))
- (return w)))
- (de warcor!> (w)
- (progn
- (cond((and ![cord!](not(equal w ![cord!]))) (msg!> 7630)))
- (cond((intersec!> w ![const!]) (msg!> 7635)))
- (cond((intersec!> w ![fun!]) (msg!> 7637))) ))
- (de warcon!> (w)
- (progn
- (cond((intersec!> w ![cord!]) (msg!> 7631)))
- (cond((intersec!> w ![fun!]) (msg!> 7632))) ))
- (de warfun!> (w)
- (progn
- (cond((intersec!> w ![cord!]) (msg!> 7633)))
- (cond((intersec!> w ![const!]) (msg!> 7634))) ))
- (de intersec!> (wa wb)
- (cond((or(null wa)(null wb)) nil)
- ((memq(car wa)wb) t)
- ((memq(car wb)wa) t)
- (t(intersec!>(cdr wa)(cdr wb)))))
- (de newid!> (w lst)
- (cond((null w) nil)
- ((not(memq(car w)lst))(cons(car w)(newid!>(cdr w)lst)))
- (t(newid!>(cdr w)lst))))
- (de pushabbr!> (w)
- (prog2
- (cond((flagp w '!+abbr) (forget1!> w)))
- (setq ![abbr!] (consmem!> w ![abbr!]))))
- %----- Unload/Write ... To/In file ---------------------------------------
- (de tofile!> (lst wb) % wb=write/unload
- (proc(w)
- (while!>(and lst(not(memqs!> (car lst) '( !> to )))) % word!!!
- (setq w(cons(car lst)w))(setq lst(cdr lst)))
- (cond
- ((and lst(eqn(length lst)2))
- (progn
- (setq lst(rdsio!> (cadr lst) 'output wb))
- (cond((eq lst !!er!!)(return !!er!!)))
- (cond((null w)(return nil)) % just file...
- (t(return(cons(reverse w) t)))))) % file and data...
- (lst(prog2(setq ![er!] 6301)(return !!er!!)))
- (t(return(cons(reverse w) nil)))))) % just data...
- %------ Show File "..."; command -----------------------------------------
- (de showfil!> (lst)
- (proc (w wf wt wss wi wd wx)
- (cond((null lst)(return nil)))
- (setq wf t)
- (cond((cdr lst)(prog2(setq ![er!] 6301)(return !!er!!))))
- (setq lst(rdsio!>(car lst) 'input nil))
- (cond((eq lst !!er!!)(return !!er!!)))
- (loop!>
- (setq w(errorset '(read) nil nil))
- (cond((atom w) % unexpected data
- (progn(cload!>)(setq ![er!] 7720)(return !!er!!)))
- ((or(equal w (ncons !$eof!$))
- (equal w '(t))
- (atom w)) % eof encountered
- (progn(cload!>)(copar!>)(return t)))
- ((and wf(not(equal w '((cout!>))))) % not .loa file format
- (progn(cload!>)(setq ![er!] 7200)(return !!er!!))))
- (setq w (car w))
- (cond((or (null w) (atom w)) nil)
- ((and (pairp w) (null wx) (eq (car w) 'sgn!>))
- (setq wx t) (shsgndim!> (cadadr w)))
- ((eq(car w) 'setq)
- (progn (setq w(cadr w))
- (cond((flagp w '!+ivar)
- (prog2(pn!> w)(gterpri!>)))) ))
- ((eq(car w) 'pushabbr!>)
- (setq w (cadadr w))
- (cond
- ((not (flagp w '!+abbr))
- (setq w (cdr (explode2 w)))
- (mapc w 'prin2)
- (terpri))))
- ((eq (car w) 'comin!>)
- (comin!> (cadadr w)))
- ((eq (car w) 'putpn!>)
- (progn (setq wt (cadadr(cddddr w)))
- (setq w (cadr(caddr w)))
- (algpri!>
- (cond((eqn wt 1) "Coordinates: ")
- ((eqn wt 2) "Constants: ")
- ((eqn wt 3) "Functions: ")) )
- (algprinwb!> w)
- (algterpri!>))))
- (setq wf nil))
- ))
- (de shsgndim!> (w)
- (proc nil
- (prin2 "Dimension is ") (prin2 (length w))
- (prin2 " with Signature (")
- (while!> w
- (cond ((eqn (car w) 1) (prin2 "+"))
- (t (prin2 "-")))
- (cond ((cdr w) (prin2 ",")))
- (setq w (cdr w)))
- (prin2 ")")
- (terpri)))
- %----- Line Length ; command ---------------------------------------------
- (de setlinel!> (lst)
- (cond((null lst) (progn
- (prin2 "Line Length is ")
- (prin2 (linelength nil))
- (prin2 ".")(terpri) ))
- ((or(cdr lst)(not(numberp(car lst)))(lessp(car lst)0))
- (prog2 (setq ![er!] 1100) !!er!!))
- (t(linelength (car lst)))))
- %-------- Show Switch ...; command 20.02.94 ------------------------------
- (de sflag!> (w)
- (prog (wa)
- (cond ((null w) (return nil))
- ((or (cdr w) (not(idp(car w))))
- (prog2 (setq ![er!] 1100) (return !!er!!))) )
- (setq w (idtostcase!> (car w)))
- (cond ((and (not (flagp w 'switch))
- (not (flagp w '!+switch)))
- (progn (setq ![er!] 6402) (doub!> w) (return !!er!!))))
- (setq wa (incom!> (cons '!* (explode2 w))))
- (prin2 w) (prin2 " is ")
- (prin2 (cond ((eval wa) "On.")(t "Off."))) (terpri)
- (return t)))
- %------- Show Status; command 06.94 --------------------------------------
- (de shstatus!> nil % 05.96
- (progn
- % REDUCE version ...
- (prin2 "Running with ")
- (cond ((boundp!> 'version!*) (prin2 (eval 'version!*)))
- (t (prin2 "REDUCE 3.3")))
- (cond ((iscsl!>) (prin2 " [CSL"))
- (t (prin2 " [PSL")))
- (cond ((islowercase!>) (prin2 " Lower-Case]"))
- (t (prin2 " Upper-Case]")))
- (cond ((os!>) (prin2 " under ") (prin2 (os!>))))
- (terpri)
- % System Directory ...
- (cond (![grgdir1!] (progn
- (prin2 "System directory: ")
- (prin2 ![grgdir1!])
- (terpri))))
- % System case ...
- (showcase!>)
- % Dimension and Signature ...
- (sdimsgn!>)
- % Metric ...
- (cond (!#!G (progn
- (prin2 " Metric: ")
- (prin2 (cond ((eqn ![mtype!] 1) "null")
- ((eqn ![mtype!] 2) "diagonal")
- ((eqn ![mtype!] 3) "general")
- (t "unknown type")))
- (prin2 (cond ((and (eqn ![dtype!] 1)
- (not(eqn ![mtype!] 1))) " and constant")
- (t " ")))
- (terpri))))
- % Frame ...
- (cond (!#!T (progn
- (prin2 " Frame: ")
- (prin2 (cond ((eqn ![ftype!] 1) "holonomic")
- ((eqn ![ftype!] 2) "diagonal")
- ((eqn ![ftype!] 3) "general")
- (t "unknown type")))
- (terpri))))
- % Basis ...
- (cond (![umod!] (progn
- (prin2 " Basis: anholonomic")
- (terpri))))
- t))
- (de sdimsgn!> nil % 05.96
- (proc (w)
- (prin2 "Dimension is ") (prin2 ![dim!])
- (prin2 " with Signature (")
- (setq w ![sgn!])
- (while!> w
- (cond ((eqn (car w) 1) (prin2 "+"))
- (t (prin2 "-")))
- (cond ((cdr w) (prin2 ",")))
- (setq w (cdr w)))
- (prin2 ")")
- (terpri)))
- %------- Show All; command -----------------------------------------------
- (de shall!> nil
- (proc (w)
- (setq w (alldata!>))
- (cond ((null w) (progn (prin2 "Nothing is known.")
- (terpri)
- (return nil))))
- (prin2 "Value of the following objects is known:") (terpri)
- (gprinreset!>)
- (while!> w
- (gprin!> " ") (pn0!>(car w)) (gterpri!>)
- (setq w (cdr w))) ))
- (de shallbuilt!> (ww)
- (proc (w wc wn wx)
- (cond ((eq (car ww) '!*) (setq wc nil))
- ((liter (car ww)) (setq wc (tostcase!> (car ww))))
- (t (return nil)))
- (setq w ![datl!])
- (gprinreset!>)
- (while!> w
- (setq wn (car (explode (caaar w))))
- (cond
- ((or (null wc) (eq wc wn))
- (cond ((null wx) (setq wx t)
- (prin2 "Built-in objects:")
- (terpri)))
- (gprin!> " ")
- (gprils0!> (lowertxt!> (caar w)))
- (gterpri!>) ))
- (setq w (cdr w)))
- (cond ((null wx) (prin2 "No such built-in objects.")
- (terpri)))))
- %------- Evaluate ...; command -------------------------------------------
- (de evalcomm!> (w fun) % o5.96
- (proc (we wb wc)
- (cond ((null w) (return nil)))
- (cond ((eq (setq w (dgood!> w)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (setq wc (car w))
- (cond((memq wc '(![cord!] ![const!] ![fun!] ![apar!])) nil)
- ((null (setq wb (eval wc))) (abse!> wc))
- (t(set wc
- (allcoll!> wb wc nil
- (cond((get wc '!=idxl)(get wc '!=idxl))
- (t '(0)))
- fun)) ))
- (cond
- ((eq wc '!#!G ) (mtype!>))
- ((eq wc '!#!G!I ) (mitype!>))
- ((eq wc '!#!T ) (ftype!>))
- ((eq wc '!#!D ) (fitype!>)) )
- (setq w (cdr w)))
- (return t)))
- % Evaluation of expression of equality ...
- (de evel!> (lst wi wn)
- (cond((null lst) nil)
- ((and (zerop(gettype!> wn))(not (flagp wn '!+equ)))
- (evalalg!> lst))
- ((and (not(zerop(gettype!> wn)))(not (flagp wn '!+equ)))
- (evalform!> lst))
- ((and (not(zerop(gettype!> wn))) (flagp wn '!+equ))
- (equationf!> (cadr lst) (caddr lst)))
- ((and (zerop(gettype!> wn))(flagp wn '!+equ))
- (equationa!> (cadr lst) (caddr lst)))))
- (de normel!> (lst wi wn)
- (cond((null lst) nil)
- ((and (zerop(gettype!> wn))(not (flagp wn '!+equ)))
- (evalalg!> lst))
- ((and (not(zerop(gettype!> wn)))(not (flagp wn '!+equ)))
- (evalform!> lst))
- ((and (not(zerop(gettype!> wn))) (flagp wn '!+equ))
- (equationf1!> (cadr lst) (caddr lst)))
- ((and (zerop(gettype!> wn))(flagp wn '!+equ))
- (equationa1!> (cadr lst) (caddr lst)))))
- %---------- Package ...; command 25.02.94 --------------------------------
- (de loadpack!> (lst bool) % bool=t - message, bool=nil - silence
- (proc (w ww wu wl)
- (cond
- ((null lst) (return nil))
- ((or (cdr lst) (not(idp(car lst))))
- (setq ![er!] 8100) (return !!er!!)))
- (setq ww (car lst))
- (setq w (explode2 ww))
- (setq wu (incom!> (mapcar w 'touc!>)))
- (setq wl (incom!> (mapcar w 'tolc!>)))
- % already loaded ...
- (cond((or (memq ww (eval 'loaded!-packages!*))
- (memq wu (eval 'loaded!-packages!*))
- (memq wl (eval 'loaded!-packages!*)))
- (cond (bool (msg!> 8101) (return t))
- (t (return t)))))
- % trying name as it is ...
- (setq w (errorset (list 'evload (list 'quote (ncons ww)))
- ![erst1!] ![erst2!]))
- (cond ((not(atom w)) (progn
- (set 'loaded!-packages!* (cons ww (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wu (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wl (eval 'loaded!-packages!*)))
- (return t))))
- % trying uppercase name ...
- (setq w (errorset (list 'evload (list 'quote (ncons wu)))
- ![erst1!] ![erst2!]))
- (cond ((not(atom w)) (progn
- (set 'loaded!-packages!* (cons ww (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wu (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wl (eval 'loaded!-packages!*)))
- (return t))))
- % trying lowercase name ...
- (setq w (errorset (list 'evload (list 'quote (ncons wl)))
- ![erst1!] ![erst2!]))
- (cond ((not(atom w)) (progn
- (set 'loaded!-packages!* (cons ww (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wu (eval 'loaded!-packages!*)))
- (set 'loaded!-packages!* (cons wl (eval 'loaded!-packages!*)))
- (return t))))
- (setq ![er!] 8102)
- (return !!er!!)))
- %---------- Solve ...; command 16.03.94 ----------------------------------
- (de solvei!> (lst)
- (prog (we wv w wr)
- (setq lst (seek1q!> lst 'for)) % word!!!
- (cond((or(null lst)(null(car lst))(null(cdr lst)))
- (prog2(setq ![er!] 2300)(return !!er!!))))
- (setq wv (memlist!> '!, (cdr lst)))
- (setq we (memlist!> '!, (reverse(car lst))))
- (setq wv (mapcar wv 'solvev!>))
- (cond((memq !!er!! wv)(return !!er!!)))
- (setq we (mapcar we 'solvee!>))
- (cond((memq !!er!! we)(return !!er!!)))
- (setq ![solveq!] nil)
- (solveprep!> we)
- (setq we ![solveq!])
- (setq ![solveq!] nil)
- (cond((null we)(prog2(setq ![er!] 2304)(return !!er!!))))
- (setq w (list 'eval!> (list 'quote
- (list 'solve (cons 'list we) (cons 'list wv)))))
- (setq w (errorset w ![erst1!] ![erst2!]))
- (cond((atom w)(prog2(setq ![er!] 2301)(return !!er!!))))
- (solveres!> (car w))
- (setq wr ![solveq!])
- (setq ![solveq!] nil)
- (cond(wr (setq ![sol!] (append wr ![sol!])))
- (t (msg!> 2302)))
- (return t)))
- (de solvev!> (w) (nz!>(translata!> w)))
- (de solveprep!> (w)
- (cond((atom w) nil)
- ((eq (car w) 'equal)
- (setq ![solveq!] (cons (solveprep1!> w) ![solveq!])))
- (t(mapc w 'solveprep!>))))
- (de solveprep1!> (w) (mapcar w 'nz!>))
- (de solveres!> (w)
- (cond((atom w) nil)
- ((eq (car w) 'equal)
- (setq ![solveq!] (cons (solveres1!> w) ![solveq!])))
- (t(mapc w 'solveres!>))))
- (de solveres1!> (w) (mapcar w 'evalalg!>))
- (de solvee!> (w)
- (cond((memq '!= w)(solveeq!> w))
- (t(prog (ww wi)
- (setq ww (dgood!> w))
- (cond((not(eq ww !!er!!))(return(solveeo!>(altdata!> ww)))))
- (cond
- ((idp(car w))(progn
- (setq wi (explode2(car w)))
- (selid!> wi nil)
- (setq wi (incomiv!> wi))
- (cond((not(flagp wi '!+equ))
- (prog2(setq ![er!] 2300)(return !!er!!))))
- (return(solveeq!>(list '!L!H!S w '!= '!R!H!S w)))))
- (t(prog2(setq ![er!] 2300)(return !!er!!))))))))
- (de solveeq!> (w)
- (proc (wa wr)
- (setq wa (seek1!> w '!=))
- (cond((or(null(car wa))(null(cdr wa)))
- (prog2(setq ![er!] 2300)(return !!er!!))))
- (setq w (list (reverse(car wa)) '!- (cdr wa)))
- (setq ![extvar!] nil)
- (setq w (translate!> w))
- (cond((or(null w)(eq w !!er!!)) (return w)))
- (cond((zerop(car w)) (return(ncons(list 'equal (cdr w) nil)))))
- (setq w (cdr w))
- (while!> w
- (setq wr (cons (list 'equal (caar w) nil) wr))
- (setq w (cdr w)))
- (return wr)))
- (de solveeo!> (w)
- (cond((null w) (prog2 (setq ![er!] 2304) !!er!!))
- (t(proc (wr)
- (while!> w
- (cond((not(flagp (car w) '!+equ))
- (prog2(setq ![er!] 2303)(return !!er!!))))
- (setq ![solveq!] nil)
- (put '![solveq!] '!=typ (gettype!> (car w)))
- (soexp!> (eval(car w)))
- (setq wr (append ![solveq!] wr))
- (setq ![solveq!] nil)
- (setq w (cdr w)))
- (return wr)))))
- (de soexp!> (w)
- (cond((atom w) nil)
- ((eq (car w) 'equal) (soexp1!> w))
- (t (mapc w 'soexp!>))))
- (de soexp1!> (w)
- (cond((zerop(get '![solveq!] '!=typ))
- (setq ![solveq!] (cons w ![solveq!])))
- (t(proc nil
- (setq w (dfsum!> (list (cadr w)
- (chsign!> t (caddr w)))))
- (while!> w
- (setq ![solveq!] (cons (list 'equal (caar w) nil) ![solveq!]))
- (setq w (cdr w)))))))
- %----- Object Declaration Command 11.94, 05.96 --------------------------
- (de obdec!> (lst type) % type=0 object, 1 equation, 2 connection ...
- (cond((null lst) nil) (t
- (proc (wn wt wi wy wd wa wb wc)
- % wn - internal id
- % wt - =type
- % wi - =idxl
- % wy - =sidxl
- % wd - =dens
- (setq wt 0) % default type is scalar ...
- (setq wn (idtra!> (car lst))) % identifier ...
- (cond ((eq wn !!er!!) (return !!er!!))
- ((null(setq lst (cdr lst))) (return
- (formnew!> wn (cond ((eqn type 2) 1) (t wt)) wi wy wd type))))
- % splitting lst into parts ...
- (setq lst (splitparts!> lst))
- (setq wa (car lst)) % indices
- (setq wb (cadr lst)) % type
- (setq wc (caddr lst)) % symmetries
- % indices ...
- (cond ((null wa) (go lab1)))
- (setq wi (indtrac!> wa))
- (cond ((eq wi !!er!!) (setq ![er!] 8602) (return !!er!!)))
- lab1
- % type ...
- (cond ((and (eqn type 2) (null wb)) (setq wt 1)))
- (cond ((null wb) (go lab2)))
- (setq wt (typetrac!> wb))
- (cond ((eq wt !!er!!) (setq ![er!] 8601) (return !!er!!)))
- (setq wd (cdr wt))
- (setq wt (car wt))
- lab2
- % symmetries ...
- (cond ((null wc) (go lab3)))
- (setq wy (symtrac!> wc wi))
- (cond ((eq wy !!er!!) (setq ![er!] 8606) (return !!er!!)))
- lab3
- (return (formnew!> wn wt wi wy wd type)) ))))
- % Forms new object by assigning appropriate flags and props ...
- (de formnew!> (wn wt wi wy wd type) % 05.96
- (proc nil
- (cond
- ((eqn type 2) % connection
- (cond ((not(eqn wt 1)) (setq ![er!] 3002) (return !!er!!)))
- (cond ((equal wi '(t nil)) (flag (ncons wn) '!+fconn)
- (flag (ncons wn) '!+noncov))
- ((equal wi '(1 0)) (flag (ncons wn) '!+hconn)
- (flag (ncons wn) '!+noncov))
- ((equal wi '((u . 2))) (flag (ncons wn) '!+uconn)
- (flag (ncons wn) '!+noncov))
- ((equal wi '((d . 2))) (flag (ncons wn) '!+dconn)
- (flag (ncons wn) '!+noncov))
- ((null wi) (setq wi '(t nil))
- (flag (ncons wn) '!+fconn)
- (flag (ncons wn) '!+noncov))
- (t (setq ![er!] 3001) (return !!er!!)))))
- (global (ncons wn))
- (flag (ncons wn) '!+ivar)
- (flag (ncons wn) '!+abbr)
- (setq ![abbr!] (cons wn ![abbr!]))
- (put wn '!=type wt)
- (cond (wi (put wn '!=idxl wi)))
- (cond (wy (put wn '!=sidxl wy)))
- (cond (wd (put wn '!=dens wd)))
- (cond ((eqn type 1) (flag (ncons wn) '!+equ))) % equation
- (while!> wi
- (cond ((spinp!>(car wi)) (put wn '!=constr '((sp!>)))))
- (setq wi (cdr wi)))
- (return t)))
- % ID translation ...
- (de idtra!> (w) % 05.96
- (prog (we wv)
- (cond
- ((not(idp w)) (prog2 (setq ![er!] 8600) (return !!er!!)))
- ((flagp w '!+grg) (prog2 (doub!> w) (msg!> 8603))))
- (setq we (explode2 w))
- (cond((badchar!> we)
- (progn (doub!> w) (setq ![er!] 8604) (return !!er!!))))
- (setq wv (incomiv!> we))
- (cond
- ((or (flagp wv '!+ivar) (flagp w '!+grgmac) (gettype!> wv))
- (progn (doub!> w) (setq ![er!] 3000) (return !!er!!))))
- (return wv)))
- (de badchar!> (lst) % 05.96
- (cond ((null lst) nil)
- ((or (digit(car lst)) (eq (car lst) '!~)) t)
- (t (badchar!>(cdr lst)))))
- % Split command in parts ....
- (de splitparts!> (lst) % 05.96
- (proc (w wr)
- (while!> (and lst (not (memqs!> (car lst) '(is with)))) % word!!!
- (setq w (cons (car lst) w))
- (setq lst (cdr lst)))
- (setq w (reverse w))
- (cond ((null lst) (return (list w nil nil)))
- ((memqs!> (car lst) '(with)) % word!!!
- (return (list w nil (cdr lst)))))
- (setq lst (cdr lst))
- (setq wr w)
- (setq w nil)
- (while!> (and lst (not (memqs!> (car lst) '(with)))) % word!!!
- (setq w (cons (car lst) w))
- (setq lst (cdr lst)))
- (cond ((null lst) (return (list wr (reverse w) nil)))
- (t (return (list wr (reverse w) (cdr lst)))))
- ))
- % Indices translation ...
- (de indtrac!> (w) % 05.96
- (proc (wr wp wt)
- (cond ((not(zerop(remainder (length w) 2))) (return !!er!!)))
- (while!> w
- (setq wp (car w))
- (cond ((not(memq wp '( !_ !. !' !^ ))) (return !!er!!)))
- (setq wt (cadr w))
- (setq wt (indtra1!> wt wp))
- (cond ((eq wt !!er!!) (return !!er!!)))
- (setq wr (cons wt wr))
- (setq w (cddr w)))
- (return(reversip wr)) ))
- % One index translation ...
- (de indtra1!> (w wp) % 05.96
- (cond
- ((not(idp w)) !!er!!)
- ((get w '!=uc) % single lc letter => holonomic or frame
- (cond ((eq wp '!') t )
- ((eq wp '!.) nil )
- ((eq wp '!^) 1 )
- ((eq wp '!_) 0 )))
- (t(prog (ww wd wl www)
- (setq ww (explode2 w))
- (cond
- ((get (car ww) '!=lc) % spinorial
- (cond ((eq (car(reverse ww)) '!~) (setq wd t)))
- (return (cons
- (cond
- ((memq wp '(!' !^)) (cond (wd 'ud) (t 'uu)))
- (t (cond (wd 'd) (t 'u))))
- (cond
- (wd (sub1(length ww)))
- (t (length ww))))))
- ((get (car ww) '!=uc) % enumerating
- (setq www (compress (cdr ww)))
- (cond
- ((idp www)
- (cond ((equal (cdr ww) '(!d !i !m)) (return '(n)))
- (t (return !!er!!))))
- ((zerop www) (return !!er!!))
- (t (return (cons 'n www)))))
- (t (return !!er!!)))))))
- % Type and Density translation ...
- (de typetrac!> (wb) % 05.96
- (prog (wt wd)
- (setq wb (splitpartsd!> wb))
- (setq wt (typetra1!> (car wb)))
- (setq wd (denstra1!> (cdr wb)))
- (cond ((or (eq wt !!er!!) (eq wd !!er!!)) (return !!er!!))
- (t (return (cons wt wd))))))
- (de splitpartsd!> (lst) % 05.96
- (proc (w)
- (while!> (and lst (not (memqs!> (car lst) '(density)))) % word!!!
- (setq w (cons (car lst) w))
- (setq lst (cdr lst)))
- (setq w (reverse w))
- (cond ((null lst) (return (cons w nil)))
- (t (return (cons w (cdr lst)))))))
- % Type translation ...
- (de typetra1!> (w) % 05.96
- (cond ((null w) 0)
- ((eqs!> w '(vector)) -1) % word!!!
- ((eqs!> w '(scalar)) 0) % word!!!
- ((eqs!> (cdr w) '(!- form)) (pformtra1!>(car w))) % word!!!
- (t !!er!!)))
- (de pformtra1!> (w) % 05.96
- (prog2
- (setq w (ntranslata!> w))
- (cond
- ((eq w !!er!!) !!er!!)
- ((lessp w 0) !!er!!)
- (t w))))
- % Density translation ...
- (de denstra1!> (w) % 05.96
- (proc (w1 w2 w3 w4 wc)
- (cond ((null w) (return nil)))
- (setq w (memlist!> '!* w))
- (cond ((eq w !!er!!) (return !!er!!)))
- (while!> w
- (setq wc (car w))
- (cond
- ((equal wc '(!s!g!n!D)) (setq w1 t))
- ((equal wc '(!s!g!n!L)) (setq w3 t))
- ((equal wc '(!D)) (setq w2 1))
- ((equal wc '(!L)) (setq w4 1))
- ((and (eq (car wc) '!D) (cdr wc) (eq (cadr wc) '!^) (cddr wc))
- (setq wc (ntranslata!>(cddr wc)))
- (cond ((eq wc !!er!!) (return !!er!!)))
- (setq w2 wc))
- ((and (eq (car wc) '!L) (cdr wc) (eq (cadr wc) '!^) (cddr wc))
- (setq wc (ntranslata!>(cddr wc)))
- (cond ((eq wc !!er!!) (return !!er!!)))
- (setq w4 wc))
- (t (return !!er!!)))
- (setq w (cdr w)))
- (cond ((or w1 w2 w3 w4) (return (list w1 w2 w3 w4)))
- (t (return nil)))))
- % Symmetries translation ...
- (de symtrac!> (wy wi) % 05.96
- (cond
- (t(proc (wr w)
- (cond ((eqs!> (car wy) 'symmetries) % word!!!
- (setq wy (cdr wy))))
- (cond ((null wy) (return nil)))
- (setq wy (memlist!> '!, wy))
- (cond ((eq wy !!er!!) (return !!er!!)))
- (while!> wy
- (setq w (symspec1!> (car wy) wi))
- (cond ((eq w !!er!!) (return !!er!!)))
- (setq wr (cons w wr))
- (setq wy (cdr wy)))
- (cond((overlapp!> wr)
- (prog2 (msg!> 8607) (return !!er!!))))
- (return(reversip wr))))))
- % One symmetry item: W = (s ( , , ))
- (de symspec1!> (w wi) % 05.96
- (cond
- ((or (null(cdr w)) (not(memq (car w) '(!a !s !c !h !A !S !C !H)))) !!er!!)
- (t(prog (wt wr)
- (setq wt (tostcase!> (car w)))
- (setq w (symspecl!> (cadr w) wi))
- (cond ((eq w !!er!!) (return !!er!!))
- ((null(cdr w)) (return !!er!!))) % length must be 2 or greater
- (cond
- ((memq wt '(!h !H))
- (cond ((or (not (eqn (length w) 2))
- (not (hequal!> w wi)))
- (return !!er!!))
- (t (return (cons wt w)))))
- ((not(allequal!> w wi)) (return !!er!!))
- (t (return (cons wt w))))))))
- % List of symmetries or indices: W = ( , , )
- (de symspecl!> (w wi) % 05.96
- (proc (wr wa)
- (setq w (memlist!> '!, w))
- (cond ((eq w !!er!!) (return !!er!!)))
- (while!> w
- (setq wa (symspec2!> (car w) wi))
- (cond ((eq wa !!er!!) (return !!er!!)))
- (setq wr (cons wa wr))
- (setq w (cdr w)))
- (return(reversip wr))))
- % General translation ...
- (de symspec2!> (w wi)
- (cond ((cdr w) (symspec1!> w wi)) % something general: s( , )
- ((atom(car w)) (symspec0!> (car w) wi)) % one index: 1
- (t (symspecl!> (car w) wi)))) % list: ( , , )
- % Just one index number ...
- (de symspec0!> (w wi)
- (cond ((and (numberp w) (leq w (length wi))) w)
- (t !!er!!))) % out of range
- (de overlapp!> (wr)
- (proc (w wa)
- (while!> wr
- (setq wa (iron1!>(car wr)))
- (cond ((intersecl!> wa w) (return !!er!!)))
- (setq w (append wa w))
- (setq wr (cdr wr)))
- (return nil)))
- % Forms list of all numbers ...
- (de iron1!> (wr)
- (cond ((null wr) nil)
- ((idp(car wr)) (iron1!>(cdr wr)))
- ((atom(car wr)) (cons (car wr) (iron1!>(cdr wr))))
- (t (append (iron1!>(car wr))
- (iron1!>(cdr wr))))))
- % Replaces ind numbers by their types ...
- (de itypes!> (w wi)
- (cond ((null w) nil)
- ((idp w) w)
- ((numberp w) (getn!> wi w))
- (t (cons (itypes!> (car w) wi) (itypes!> (cdr w) wi)))))
- % All symmetries in the list are identical ...
- (de allequal!> (w wi)
- (cond ((null(cdr w)) t)
- ((equal (itypes!> (car w) wi) (itypes!> (cadr w) wi))
- (allequal!> (cdr w) wi))
- (t nil)))
- (de hequal!> (w wi)
- (prog (w1 w2)
- (setq w1 (itypes!> (car w) wi))
- (setq w2 (cotype!>(itypes!> (cadr w) wi)))
- (return(equal w1 w2))))
- (de cotype!> (w)
- (cond
- ((pairp w)
- (cond
- ((eq (car w) 'u) (cons 'd (cdr w)))
- ((eq (car w) 'd) (cons 'u (cdr w)))
- ((eq (car w) 'uu) (cons 'ud (cdr w)))
- ((eq (car w) 'ud) (cons 'uu (cdr w)))
- (t (mapcar w 'cotype!>))))
- (t w)))
- %========== End of GRGcomm.sl =============================================%
|