12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790 |
- %==========================================================================%
- % GRGtrans.sl Formula Translator %
- %==========================================================================%
- % GRG 3.2 Standard Lisp Source Code (C) 1988-96 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. %
- %==========================================================================%
- %---------- General GRG Translator ---------------------------------------
- % Translation with (ERROR ...) interruption ...
- (de translate1!> (lst)
- (cond (lst (unievaluate!> (unitra!> lst)))
- (t nil)))
- % Translation with !!ER!! return ...
- (de translate!> (lst)
- (prog nil
- (cond((null lst)(return nil)))
- (setq ![lsrs!] nil)
- (setq lst
- (errorset!> (list2 'unitra!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (setq lst
- (errorset!> (list2 'unievaluate!> (list 'quote(car lst)))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Translate for equations with !!ER!! return ...
- (de translateeq!> (lst)
- (prog nil
- (cond((null lst)(return nil)))
- (setq ![lsrs!] nil)
- (setq lst
- (errorset!> (list2 'unitraeq!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (setq lst
- (errorset!> (list2 'unievaluateeq!> (list 'quote(car lst)))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Pre-Translation with !!ER!! return ...
- (de pretrans!> (lst)
- (prog nil
- (cond ((null lst) (return nil)))
- (setq ![lsrs!] nil)
- (setq lst
- (errorset!> (list2 'unitra!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Pre-Translation for equations with !!ER!! return ...
- (de pretranseq!> (lst)
- (prog nil
- (cond((null lst)(return nil)))
- (setq ![lsrs!] nil)
- (setq lst
- (errorset!> (list2 'unitraeq!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Pre-Translation with !!ER!! return with external vars ...
- (de pretransext!> (lst)
- (prog nil
- (cond ((null lst) (return nil)))
- (setq ![lsrs!] nil)
- (setq lst
- (errorset!> (list2 'unitraext!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Final translation with !!ER!! return ...
- (de fintrans!> (lst)
- (prog nil
- (setq lst
- (errorset!> (list2 'unievaluate!> (list 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % Evaluation with simplification ...
- (de unievaluate!> (lst)
- (prog2 (setq lst(unieval!> lst))
- (cond((null lst) lst)
- ((zerop(car lst))(cona!> 0 (cdr lst)))
- (t(conf!>(car lst)(cdr lst))))))
- % Evaluation with simplification for equations ...
- (de unievaluateeq!> (lst)
- (prog (wl wr)
- (setq wl (unievaluate!>(car lst)))
- (setq wr (unievaluate!>(cdr lst)))
- (cond((and(null wl)(null wr)) (return nil))
- ((and wl wr (not(eqn(car wl)(car wr))))(err!> 2209)))
- (return
- (cond((and wl wr)(cons(car wl)(list 'equal (cdr wl) (cdr wr))))
- (wl (cons(car wl)(list 'equal (cdr wl) nil)))
- (wr (cons(car wr)(list 'equal nil (cdr wr)))) ))))
- % Evaluation ...
- (de unieval!> (lst)
- (cond((atom lst) lst)
- ((or(numberp(car lst))(pairp(car lst))(null(car lst))) lst)
- ((flagp (car lst) '!+specexec) (apply (car lst) (cdr lst)))
- (t(apply (car lst) (mapcar (cdr lst) (function unieval!>))))))
- % Final value predicate ...
- (de concrp!> (w)
- (cond((or(null w)(numberp(car w))) t) (t nil)))
- % Final valies list predicate ...
- (de concrpl!> (lst)
- (cond((null lst) t)
- ((or(null(car lst))(numberp(caar lst))) (concrpl!>(cdr lst)))
- (t nil)))
- % Pre-Translation with ERR interrupt ...
- (de unitra!> (lst)
- (einstsum!> (unitra0!>(expandsym!> lst)) ![extvar!]))
- % Pre-Translation with ERR and external variables ...
- (de unitraext!> (lst)
- (cond (![extvar!] (unitra!> lst))
- (t (prog (w we)
- (setq w (einstsum!> (unitra0!>(expandsym!> lst)) nil))
- (setq we (freevar!> w nil))
- (setq ![extvara!] (reverse we))
- (return w)))))
- % Pre-Translation with ERR interrupt for equations ...
- (de unitraeq!> (lst)
- (cond((or (null(setq lst (seek1!> lst '!=)))
- (null(cdr lst)) (null(car lst)) )
- (err!> 2208))
- (t(cons(unitra!>(reverse(car lst)))(unitra!>(cdr lst))))))
- %---------- Einstein Summation -------------------------------------------
- % This is main function ...
- (de einstsum!> (lst we)
- (cond((atom lst) lst)
- ((numberp(car lst)) lst)
- ((null(freevar!> lst we)) lst) % no any free variables
- % Spacial treatment for Sum and Prod since summation
- % variables should not be treated as free variables ...
- ((memq (car lst) '(sumexec!> prodexec!>))
- (list3(car lst)(cadr lst)(einstsum!>(caddr lst)
- (consmem!>(caaadr lst)we))))
- % Product of two expressions A*B. We make summation if
- % there is the same free variables in both A and B ...
- ((flagp(car lst) '!+multop2)(prog (w1 w2 w)
- (setq w1 (freevar!> (cadr lst) we))
- (setq w2 (freevar!> (caddr lst) we))
- (setq w (intersecl!> w1 w2))
- (cond((and(null w1)(null w2))(return lst)) % no any free vars
- ((null w)(return(list3 % empty intersection => no summation
- (car lst)
- (einstsum!>(cadr lst)we)
- (einstsum!>(caddr lst)we))))
- (t(return(mkeinsum!> w lst we)))))) % make new sum
- % This is function f(A). We make summation if only
- % some free variable appear in A at least twice ...
- ((eq(car lst) 'funapply!>)(prog (w)
- (setq w (freevar1!> (caddr lst) we))
- (setq w (errsingl!> w nil))
- (cond ((null w) (return lst))
- (t (return(mkeinsum0!> w lst))))))
- % This is sum of terms. Just apply EINSTSUM> to each
- % term independently ...
- ((eq(car lst) 'plus!>)
- (list2 (car lst) (einstsum1!> (cadr lst) we)))
- % Others ...
- (t(cons (car lst) (einstsum1!> (cdr lst) we)))))
- % Just apply EINSTSUM> to the each element of list ...
- (de einstsum1!> (lst we)
- (cond((null lst) nil)
- (t(cons (einstsum!> (car lst) we)
- (einstsum1!> (cdr lst) we)))))
- % Make Summation for Function ...
- (de mkeinsum0!> (w lst)
- (cond((null(cdr w))
- (list3 'sumexec!> (ncons w) lst))
- (t(list3 'sumexec!> (ncons(ncons(car w)))
- (mkeinsum0!> (cdr w) lst)))))
- % Make Summation for product ...
- (de mkeinsum!> (w lst we)
- (cond((null(cdr w))
- (list3 'sumexec!> (ncons w)
- (list3 (car lst)
- (einstsum!>(cadr lst)(consmem!>(car w)we))
- (einstsum!>(caddr lst)(consmem!>(car w)we)))))
- (t(list3 'sumexec!> (ncons(ncons(car w)))
- (mkeinsum!> (cdr w) lst (consmem!> (car w) we))))))
- % Collects all DUMMYVAR!> variables in expr LST ...
- % WE - list of vars already excluded from consideration
- % Takes into account special forms like Sum, Prod ...
- (de freevar!> (lst we)
- (cond((atom lst) nil)
- ((numberp(car lst)) nil)
- ((eq(car lst) 'dummyvar!>)
- (cond((not(memq(cadr lst)we))(cdr lst))))
- ((memq (car lst) '(sumexec!> prodexec!>))
- (freevar!> (caddr lst) (consmem!>(caaadr lst)we)))
- (t(appmem!>(freevar!> (car lst) we)
- (freevar!> (cdr lst) we)))))
- % Like FREEVAR> but repeated vars can be collected twice ...
- (de freevar1!> (lst we)
- (cond((atom lst) nil)
- ((numberp(car lst)) nil)
- ((eq(car lst) 'dummyvar!>)
- (cond((not(memq(cadr lst)we))(cdr lst))))
- ((memq (car lst) '(sumexec!> prodexec!>))
- (freevar1!> (caddr lst) (consmem!>(caaadr lst)we)))
- (t(append(freevar1!> (car lst) we)
- (freevar1!> (cdr lst) we)))))
- % Produces Error if some var in the list present only once ...
- %(de errsingl!> (w wr)
- % (cond ((null w) wr)
- % ((memq (car w) wr) (errsingl!> (cdr w) wr))
- % ((memq (car w) (cdr w)) (errsingl!> (cdr w) (cons (car w) wr)))
- % (t (prog2 (doub!>(car w)) (err!> 2018)))))
- % This version just removes single var from the list ...
- (de errsingl!> (w wr)
- (cond ((null w) wr)
- ((memq (car w) wr) (errsingl!> (cdr w) wr))
- ((memq (car w) (cdr w)) (errsingl!> (cdr w) (cons (car w) wr)))
- (t (errsingl!> (cdr w) wr))))
- % Intersections of two lists ...
- (de intersecl!> (w1 w2)
- (cond((or(null w1)(null w2)) nil)
- (t(proc (w)
- (while!> w1
- (cond((memq (car w1) w2)(setq w(cons(car w1)w))))
- (setq w1(cdr w1)))
- (return w)))))
- %------- Main Operations Translation -------------------------------------
- % Main sum/difference translation with [,] ...
- (de unitra0!> (lst)
- (cond ((atom lst) (atomtr!> lst)) % atom
- ((and(pairp lst)(null(cdr lst)))(unitra0!>(car lst))) % next level
- (t(proc (w)
- (cond((memq '![ lst)(setq lst(vbrctr!> lst)))) % [ , ] ?
- (cond((not(memq(car lst) '(!+ !-))) % + - translation
- (setq lst(cons '!+ lst))))
- (setq w(mems!> '(!+ !-) (reverse lst) nil))
- (cond((eq w !!er!!) (err!> 2017)))
- (setq w(listra!>(reversip w)))
- (return(cond((null(cdr w))(car w))
- ((concrpl!> w) (plus!> w))
- (t(list2 'plus!> w))))))))
- % List of Expressions translation with ~~ treatment ...
- (de listra!> (lst)
- (proc (w)
- (while!> lst
- (cond
- ((eq(caaar lst) '!~!~)
- (cond((null w) (err!> 2110))
- ((eq(cdar lst) '!+)
- (setq w(cons(list2 're2!>(car w))(cdr w))))
- (t(setq w(cons(list2 'im2i!>(car w))(cdr w))))))
- ((eq(cdar lst) '!+)(setq w(cons(termtr!>(caar lst))w)))
- (t(setq w(cons(list2 'minus!> (termtr!>(caar lst)))w))))
- (setq lst(cdr lst)))
- (return w)))
- % Atom translation ...
- (de atomtr!> (w)
- (cond ((zerop w) nil) % zero
- ((stringp w)(prog2(doubs!> w) (err!> 2019)))
- ((or(numberp w)(flagp w '!+grgvar))(cons 0 w))% number or variable
- ((get w '!=subind) (prog2 % tensorial index
- (setq w (get w '!=subind))
- (cond((zerop w) nil)
- (t(cons 0 w)))))
- (t(prog (wn wi wd wss wb) % data component
- (setq wss w)
- (setq w (explode2 w))
- (setq wb (selid!> w nil)) % w - id wb - indices
- (setq wn (incomiv!> w))
- (cond
- ((flagp wn '!+macros3) % it is macro 3 scalar
- (cond (wb (doub!> wss) (err!> 2018))
- (t (require!> (get wn '!=ndl))
- (return (getsac!> wn nil)))))
- ((flagp wn '!+macros2) % it is macro 2 component
- (cond ((null wb) (doub!> wss) (err!> 2018))
- (t (return
- (funtr!> (list (incom!> w)
- (addcomm!> wb wss)) nil)))))
- ((not(flagp wn '!+ivar)) % it is not an object
- (cond ((eq wss '!~!~) (err!> 2110))
- (t (return(list2 'dummyvar!> wss))))))
- (cond((and(null wb)(get wn '!=idxl))
- (return(list2 'dummyvar!> wss))))
- (setq wi(mapcar wb 'digorerr!>)) % indixes list
- (cond((memq !!er!! wi)
- (return(list2 'dummyvar!> wss))))
- (cond((eq(goodidxl!> wi (get wn '!=idxl)) !!er!!)
- (return(list2 'dummyvar!> wss))))
- (require1!> wn)
- (cond((and ![umod!] (memq wn '(!#!b !#!e)))
- (return(cons (cond((eq wn '!#!b) 1)(t -1))
- (mkdx!> (car wi))))))
- (return(getsac!> wn wi)) % extracting value
- ))))
- (de addcomm!> (w wss)
- (cond ((null (cdr w)) (ncons(addcomm1!> (car w) wss)))
- (t (cons (addcomm1!> (car w) wss)
- (cons '!, (addcomm!> (cdr w) wss))))))
- (de addcomm1!> (w wss)
- (cond ((digit w) (compress(ncons w)))
- (t (doub!> wss) (err!> 2018))))
- % * | /\ _| translation ...
- (de termtr!> (lst)
- (prog (w wss wo)
- (cond((null lst) (err!> 2016)))
- (setq w(seek!> lst '( !* !/!\ !_!| !| !. )))
- (cond((null w) (return(quotr!> lst))))
- (setq wo (get (cadr w) '!=op2))
- (setq wss (termtr1!> (cddr w)))
- (setq w (quotr!>(reverse (car w))))
- (return (cond((and(concrp!> w)(concrp!> wss))
- (apply wo (list2 w wss)))
- (t (list wo w wss))))))
- (de termtr1!> (lst)
- (prog (wa wb wo)
- (cond((null lst) (err!> 2016)))
- (setq wa(seek!> lst '( !* !/!\ !_!| !| !. )))
- (cond((null wa) (return(quotr!> lst))))
- (setq wo (get (cadr wa) '!=op2))
- (setq wb (termtr1!> (cddr wa)))
- (setq wa (quotr!>(reverse(car wa))))
- (return (cond((and(concrp!> wa)(concrp!> wb))
- (apply wo (list2 wa wb)))
- (t (list wo wa wb))))))
- % / translation ...
- (de quotr!> (lst)
- (cond((null lst) (err!> 2016))
- ((not(memq '!/ lst))(exptr!> lst))
- (t(prog (w)
- (setq w(memlist!> '!/ lst))
- (cond((eq w !!er!!) (err!> 2016)))
- (setq w (mapcar w 'exptr!>))
- (return(quotmk!>(car w)(cdr w)))))))
- (de quotmk!> (lst1 lst2)
- (cond((null lst2) lst1)
- ((and(concrp!> lst1)(concrp!>(car lst2)))
- (quotmk!> (quoti!> lst1 (car lst2))
- (cdr lst2)))
- (t(quotmk!> (list 'quoti!> lst1 (car lst2))
- (cdr lst2)))))
- % ** or ^ translation ...
- (de exptr!> (lst)
- (prog (w wb)
- (cond((null lst) (err!> 2016)))
- (setq w(seek!> lst '(!*!* !^) ))
- (cond((null w)(return(kertr!> lst))))
- (setq wb (exptr!> (cddr w)))
- (setq w (kertr!>(reverse(car w))))
- (return (cond((and(concrp!> w)(concrp!> wb))
- (exp!> w wb))
- (t(list 'exp!> w wb))))))
- % d # ~ translation ...
- (de kertr!> (lst)
- (cond((null lst) (err!> 2015))
- ((pairp(car lst))(cond((cdr lst) (err!> 2014))
- (t(unitra0!>(car lst)))))
- ((not(cdr lst)) (atomtr!>(car lst)))
- ((get(car lst) '!=sysfun)
- (prog (w)
- (setq w (get (car lst) '!=sysfun))
- (setq lst (kertr!> (cdr lst)))
- (return (cond((concrp!> lst) (apply w (ncons lst)))
- (t (list2 w lst))))))
- (t(funtr!> lst t))))
- % [ , ] translation
- (de vbrctr!> (lst)
- (prog (wa wd w)
- (setq lst(seek1!> lst '![ ))
- (cond((null(cdr lst)) (err!> 2001)))
- (setq wa(car lst)) (setq lst(cdr lst))
- (setq lst(seek1!> lst '!] ))
- (cond((or(null lst)(null(car lst))) (err!> 2001)))
- (setq wd(cdr lst)) (setq lst(car lst))
- (setq w(seek1!> lst '!, ))
- (cond((or(null w)(null(car w))(null(cdr w))(memq '!, (cdr w)))
- (err!> 2001)))
- (return(app!> wa (cons 'vbrc!> (cons(reverse lst) wd))))))
- % Function translation ...
- (de funtr!> (lst bool) % bool=t - einstein summation rule is allowed
- (cond((or(null lst)(atom lst)(not(eqn(length lst)2))
- (not(idp(car lst))))
- (err!> 2021))
- ((atom(cadr lst))(err!> 2021))
- ((get (car lst) '!=spectr) % Sum Prod LHS RHS SUB Lim ...
- (apply (get (car lst) '!=spectr) (cdr lst)))
- (t(prog (w wt wm wx)
- (cond((not(or
- (eq(car lst) 'vbrc!>)
- (flagp (car lst) '!+fun)
- (redgood!> (car lst))
- (setq wt(get(car lst) '!=macros))
- (gettype!> (setq wt (incomiv!>(explode(car lst)))) )))
- (prog2(doub!>(car lst)) (err!> 2022))))
- (setq w(cond(wt wt)(t (car lst)))) % wt=t - internal variable
- (setq lst(cadr lst)) % parameters list
- (setq lst(memlist!> '!, lst))
- (cond((eq lst !!er!!) (err!> 2020)))
- (cond((and wt (get wt '!=idxl))(prog2 % if internal var =>
- (setq wm (mapcar lst 'selmani!>)) % indices manipul.
- (cond((setq wx(orl!> wm))
- (setq lst (mapcar lst 'delmani!>)))))))
- (setq lst (mapcar lst (function unitra0!>)))
- (return(cond((concrpl!> lst)
- (funapply!> w lst wm))
- (t(list 'funapply!> w lst wm))))))))
- %---------- Indices Manipulations ----------------------------------------
- % Selects indices manipulation prefixes ...
- (de selmani!> (w)
- (cond ((eq (setq w (car w)) '!') 1)
- ((eq w '!.) 2)
- ((eq w '!^) 3)
- ((eq w '!_) 4)
- (t nil)))
- % Delets iddices manipulation prefixes from expression ...
- (de delmani!> (w)
- (cond ((flagp (car w) '!+indexman)
- (cond ((null(cdr w)) (err!> 2020))
- (t (cdr w))))
- (t w)))
- % Indices manipulations translation ...
- (de manitr!> (wf wm) % wf - int.var., wm - manip. types list
- (cond ((null(orl!> wm)) nil)
- ((null(orl!>(setq wm (manitr1!> wm (get wf '!=idxl))))) nil)
- (t wm)))
- % Manipulation for one index. Prepares action ...
- (de manitr1!> (wm wi) % wm - manip.types list, wi - idxl
- (cond ((null wm) nil)
- (t (cons (manitr2!> (car wm) (car wi))
- (manitr1!> (cdr wm) (cdr wi)) ))))
- (de manitr2!> (wm wi)
- (cond
- ((null wm) nil)
- ((enump!> wi) nil)
- ((eqn wm 1) % ' cvalificator - up
- (cond
- ((and (spinp!> wi) (not(upperp!> wi)))
- (require!> '(!#!G)) (ncons(cdr wi))) % .s -> 's
- ((holpd!> wi) % .g -> 't
- (require!> '(!#!G!I !#!D)) 9)
- ((tetrpd!> wi) % .t -> 't
- (require!> '(!#!G!I)) 1)
- ((holpu!> wi) % 'g -> 't
- (require!> '(!#!T)) 5)
- (t nil)))
- ((eqn wm 2) % . cvalificator - down
- (cond
- ((and (spinp!> wi) (upperp!> wi))
- (require!> '(!#!G)) (ncons(minus(cdr wi)))) % 's -> .s
- ((holpu!> wi) % 'g -> .t
- (require!> '(!#!G !#!T)) 10)
- ((tetrpu!> wi) % 't -> .t
- (require!> '(!#!G)) 2)
- ((holpd!> wi) % .g -> .t
- (require!> '(!#!D)) 6)
- (t nil)))
- ((eqn wm 3) % ^ cvalificator - g up
- (cond
- ((spinp!> wi) (err!> 9913))
- ((holpd!> wi) % .g -> 'g
- (require!> '(!#!G!I !#!D)) 3)
- ((tetrpd!> wi) % .t -> 'g
- (require!> '(!#!G!I !#!D)) 11)
- ((tetrpu!> wi) % 't -> 'g
- (require!> '(!#!D)) 7)
- (t nil)))
- ((eqn wm 4) % _ cvalificator - g down
- (cond
- ((spinp!> wi) (err!> 9913))
- ((holpu!> wi) % 'g -> .g
- (require!> '(!#!G !#!T)) 4)
- ((tetrpu!> wi) % 't -> .g
- (require!> '(!#!G !#!T)) 12)
- ((tetrpd!> wi) % .t -> .g
- (require!> '(!#!T)) 8)
- (t nil)))
- ))
- % Qualified GET data component with ind. manipulations ...
- (de getmc!> (w wi wa wm)
- (cond ((zerop(gettype!> w))
- (cona1!> 0 (getm!> w wi wa wm)))
- (t (conf1!> (gettype!> w) (getm!> w wi wa wm)))))
- % GET dat component with ind. manipulation ...
- (de getm!> (w wi wa wm) % w - int.var. wa - ind.list wm - manipul.
- (cond ((null wa) (getsa!> w (reverse wi))) (t
- (proc (wc wg wl we wr wo wx)
- (setq wl wa) (setq wo wi)
- (while!> wm
- (cond((null(car wm)) (setq wi(cons(car wl)wi)))
- ((singlmanp!>(car wm)) (prog2 % the `diagonal' manipulation
- (setq wi (cons (rasin!> (car wl) (car wm)) wi))
- (setq wc (cons (rasco!> (car wl) (car wm)) wc)) ))
- (t(progn (setq we t)
- (setq wx t)
- (setq wr (getm1!> w wi wl wm)) )))
- (exitif wx)
- (setq wl (cdr wl))
- (setq wm (cdr wm)) )
- (cond((null wc)(return(cond(we wr)
- (t(getsa!> w(cond
- (wo(append(reverse wo)wa))
- (t wa)))))))
- ((null(setq wc(mktimes!> wc))) (return nil))
- ((zerop(gettype!> w))
- (return (mktimes!>(list wc (cond(we wr)
- (t(getsa!> w(reverse wi))))))))
- (t(return (fndfpr!> wc (cond(we wr)
- (t(getsa!> w(reverse wi))))))))
- ))))
- (de getm1!> (w wi wa wm)
- (proc (wc wr wt)
- (fordim!> m do (prog2
- (setq wc (rasco2!> (car wa) m (car wm)))
- (cond(wc(prog2
- (setq wt(getm!> w (cons m wi) (cdr wa) (cdr wm)))
- (cond(wt
- (setq wr (cons
- (cond((zerop(gettype!> w))
- (mktimes!>(list2 wc wt)))
- (t(fndfpr!> wc wt))) wr)))))))))
- (cond(wr
- (cond((zerop(gettype!> w))(return(cons 'plus wr)))
- (t(return(dfsum!> wr))))))))
- % `Diagonal' manipulation predicate. So in this case we
- % do not need make a sum for rasing or lowering of the index ...
- (de singlmanp!> (wt) % wt - manipulation type
- (cond ((pairp wt) t) % spinorial
- ((eqn wt 1) (imotop!>)) % m^ab .t -> 't GI
- ((eqn wt 2) (motop!>)) % m_ab 't -> .t G
- ((eqn wt 3) (and (imotop!>) (ifdiagp!>))) % g^ab .g -> 'g GI D
- ((eqn wt 4) (and (motop!>) (fdiagp!>))) % g_ab 'g -> .g G T
- ((eqn wt 5) (fdiagp!>)) % h^a_m 'g -> 't T
- ((eqn wt 6) (ifdiagp!>)) % h_a^m .g -> .t D
- ((eqn wt 7) (ifdiagp!>)) % h^m_a 't -> 'g D
- ((eqn wt 8) (fdiagp!>)) % h_m^a .t -> .g T
- ((eqn wt 9) (and (imotop!>) (ifdiagp!>))) % h^am .g -> 't GI D
- ((eqn wt 10) (and (motop!>) (fdiagp!>))) % h_am 'g -> .t G T
- ((eqn wt 11) (and (imotop!>) (ifdiagp!>))) % h^ma .t -> 'g GI D
- ((eqn wt 12) (and (motop!>) (fdiagp!>))) % h_ma 't -> .g G T
- (t nil)))
- % Index one-to-one map for `diagonl' manipulation ...
- (de rasin!> (w wt) % w - index, wt - manipulation type
- (cond ((pairp wt) (difference (abs!>(car wt)) w)) % spinorial
- ((and (imnullp!>) (member wt '(1 3 9 11))) % null inv metric
- (rasinst!> w))
- ((and (mnullp!>) (member wt '(2 4 10 12))) % null metric
- (rasinst!> w))
- (t w))) % any other
- % null indices ...
- (de rasinst!> (w)
- (cond ((eqn w 0) 1)
- ((eqn w 1) 0)
- ((eqn w 2) 3)
- ((eqn w 3) 2)))
- % Multiplier for `diagonal' manipulation ...
- (de rasco!> (w wt) % w - index, wt - manipulation type
- (cond ((pairp wt) % Spinorial
- (cond
- ((lessp (car wt) 0) (expt -1 w)) % 's -> .s
- (t (expt -1 (difference (car wt) w))))) % .s -> 's
- ((and (mnullp!>) (member wt '(2 4 10 12))) % Null Metric
- (cond
- ((eqn wt 2) (rascost!> w)) % m_ab 't -> .t
- ((eqn wt 4) (gmetr!> w (rasinst!> w))) % g_mn 'g -> .g
- ((eqn wt 10) (hlam!> w (rasinst!> w))) % h_am 'g -> .t
- ((eqn wt 12) (hlam!> (rasinst!> w) w)))) % h_ma 't -> .g
- ((and (imnullp!>) (member wt '(1 3 9 11))) % Null Inv Metric
- (cond
- ((eqn wt 1) (rascost!> w)) % m^ab .t -> 't
- ((eqn wt 3) (gimetr!> w (rasinst!> w))) % g^mn .g -> 'g
- ((eqn wt 9) (huam!> w (rasinst!> w))) % h^am .g -> 't
- ((eqn wt 11) (huam!> (rasinst!> w) w)))) % h^ma .t -> 'g
- (t (rasco2!> w w wt)))) % Any Other
- % Null metric ...
- (de rascost!> (w)
- (cond ((pmmm!>) (cond ((lessp w 2) 1) (t -1)) ) % +---
- (t (cond ((lessp w 2) -1) (t 1)) ))) % -+++
- % Gives the coefficient for non-daigonal index manipulation ...
- (de rasco2!> (wa wm wt) % wm - summation index
- (cond ((eqn wt 1) (getimetr!> wa wm)) % m^ab .t -> 't GI
- ((eqn wt 2) (getmetr!> wa wm)) % m_ab 't -> .t G
- ((eqn wt 3) (gimetr!> wa wm)) % g^ab .g -> 'g GI D
- ((eqn wt 4) (gmetr!> wa wm)) % g_ab 'g -> .g G T
- ((eqn wt 5) (ham!> wa wm)) % h^a_m 'g -> 't T
- ((eqn wt 6) (hiam!> wa wm)) % h_a^m .g -> .t D
- ((eqn wt 7) (hiam!> wm wa)) % h^m_a 't -> 'g D
- ((eqn wt 8) (ham!> wm wa)) % h_m^a .t -> .g T
- ((eqn wt 9) (huam!> wa wm)) % h^am .g -> 't GI D
- ((eqn wt 10) (hlam!> wa wm)) % h_am 'g -> .t G T
- ((eqn wt 11) (huam!> wm wa)) % h^ma .t -> 'g GI D
- ((eqn wt 12) (hlam!> wm wa)) % h_ma 't -> .g G T
- ))
- %---------- Cvalified simplification -------------------------------------
- (de cona!> (w lst)
- (cond ((or(null lst)(null(setq lst(zn!>(eval!> lst)))))nil)
- (t(cons 0 lst))))
- (de conf!> (w lst)
- (cond ((or(null lst)(null(setq lst(evalform!> lst))))nil)
- (t(cons w lst))))
- (de cona1!> (w lst)
- (cond ((null lst) nil)
- (t (cons 0 lst))))
- (de conf1!> (w lst)
- (cond ((null lst) nil)
- (t (cons w lst))))
- %------- Evaluation Functions --------------------------------------------
- % Function evaluator ...
- (de funapply!> (wf lst wm) % wf - function id or internal data var
- (prog (w wi wt) % lst - paramaters, wm - index manipulation
- (setq lst (mapcar lst (function unieval!>)))
- (cond((eq wf 'vbrc!>) (return(apply 'vbrc!> lst))) % [ , ]
- ((flagp wf '!+macros)(return(apply wf (ncons lst)))) % macro tensor
- ((setq wt (gettype!> wf)) (progn % data component
- % we need this data ...
- (cond ((flagp wf '!+macros2)
- (require!> (get wf '!=ndl)))
- (t (require1!> wf)))
- (setq wi (get wf '!=idxl))
- % translating indices ...
- (setq lst (mapcar lst (function indextr!>)))
- (cond
- ((eq (goodidxl!> lst wi) !!er!!)
- (cond
- % index out of range ...
- ((eqn ![er!] 21022) (err!> ![er!]))
- ((eqn ![er!] 21023) (err!> ![er!]))
- % wrong number of indices ...
- (t (return(tryexp!> wf lst wm))))))
- % special case: b e in basis mode ...
- (cond ((and ![umod!] (memq wf '(!#!b !#!e)))
- (return (cons
- (cond ((eq wf '!#!b) 1) (t -1))
- (mkdx!> (car lst))))))
- (cond
- ((setq wm (manitr!> wf wm)) % ind. manipul.
- (return (getmc!> wf nil lst wm)))
- (t (return (getsac!> wf lst))))
- )))
- % and this is really function ...
- (setq wt (mapcar lst 'auxfun2!>))
- (cond ((memq !!er!! wt) (return(trydistr!> wf lst))))
- (return (cons 0 (cons wf wt)))))
- (de auxfun2!> (w)
- (cond ((null w) 0)
- ((not(zerop(car w))) !!er!!)
- (t (cdr w))))
- % Function can be applied distributively to form
- % or vector on one and only one argument ...
- (de trydistr!> (wf lst)
- (proc (wa wb w we wt wr)
- (while!> lst
- (setq w (car lst))
- (cond ((null w) (setq w 0))
- ((not(zerop(car w))) (go lab))
- (t (setq w (cdr w))))
- (setq wa (cons w wa))
- (setq lst (cdr lst)))
- lab
- (setq wt (caar lst)) % type
- (setq we (cdar lst)) % form or vector expression
- (setq lst (cdr lst))
- (setq wb (mapcar lst 'auxfun2!>))
- (cond ((memq !!er!! wb) (err!> 2023)))
- (while!> we
- (setq wr (cons (cons (cons wf (app!> wa (cons (caar we) wb)))
- (cdar we))
- wr))
- (setq we (cdr we)))
- (return(cons wt (reversip wr)))))
- % Trying expand summed indices ...
- % wf - int.var., wl - list of indices, wm - list of manipulations
- (de tryexp!> (wf wl wm)
- (cond ((sp!>) (err!> ![er!])) (t
- (proc (wi wll wmm wm1 wl1 wd wss)
- (setq wi (get wf '!=idxl)) % idxl
- (cond ((null wm) (setq wm (mknlist!> nil (length wi)))))
- (while!> wi
- (cond
- ((null wl) (err!> ![er!])) % wrong number of indices
- % Summed spinor index ...
- ((and (spinp!>(car wi)) (greaterp (dimid!>(car wi)) 1))
- (setq wd (dimid!>(car wi)))
- (while!> (geq wd 1)
- (cond ((null wl) (err!> ![er!]))
- (t (setq wl1 (cons (car wl) wl1))
- (setq wm1 (cons (car wm) wm1))
- (setq wl (cdr wl))
- (setq wm (cdr wm))))
- (setq wd (sub1 wd)))
- (setq wll (cons (reverse wl1) wll))
- (setq wmm (cons (reverse wm1) wmm))
- (setq wl1 nil) (setq wm1 nil))
- % Tetrad index ...
- ((tetrp!>(car wi))
- (setq wd 2)
- (while!> (geq wd 1)
- (cond ((null wl) (err!> ![er!]))
- (t (setq wl1 (cons (car wl) wl1))
- (setq wm1 (cons (car wm) wm1))
- (setq wl (cdr wl))
- (setq wm (cdr wm))))
- (setq wd (sub1 wd)))
- (setq wll (cons (reverse wl1) wll))
- (setq wmm (cons (reverse wm1) wmm))
- (setq wl1 nil) (setq wm1 nil))
- (t
- (setq wll (cons (car wl) wll))
- (setq wmm (cons (manitr2!> (car wm) (car wi)) wmm))
- (setq wl (cdr wl))
- (setq wm (cdr wm))))
- (setq wi (cdr wi)))
- (cond ((or wm wl) (err!> ![er!]))) % wrong number of indices
- (setq wi (reverse(get wf '!=idxl)))
- (setq wss (signchange!> wll wmm wi))
- (setq wm (indexchange!> wll wmm wi))
- (setq wl (car wm))
- (setq wm (cdr wm))
- (return
- (cond (wss (minus!>(getmc!> wf nil wl wm)))
- (t (getmc!> wf nil wl wm))))
- ))))
- (de signchange!> (wll wmm wi)
- (proc (wss)
- (while!> wll
- (cond
- ((and (pairp (car wll)) (signchange1!> (car wll) (car wmm) (car wi)))
- (setq wss (not wss)) ))
- (setq wll (cdr wll))
- (setq wmm (cdr wmm))
- (setq wi (cdr wi)))
- (return wss)))
- (de signchange1!> (wl wm wi)
- (proc (wss wl1 wm1)
- (while!> wl
- (setq wm1 (car wm))
- (setq wl1 (car wl))
- (cond ((or (lessp wl1 0) (greaterp wl1 1)) (err!> 21022))
- ((or (eqn wm1 3) (eqn wm1 4)) (err!> 9913)))
- (cond
- ((and (eqn wm1 1) (not(upperp!> wi)) (eqn wl1 0)) % index up
- (setq wss (not wss)))
- ((and (eqn wm1 2) (upperp!> wi) (eqn wl1 1)) % index down
- (setq wss (not wss))))
- (setq wl (cdr wl))
- (setq wm (cdr wm)))
- (cond ((and (tetrpd!> wi) (not(pmmm!>))) (setq wss (not wss))))
- (return wss)))
- (de indexchange!> (wl wm wi)
- (proc (wll wmm)
- (while!> wl
- (cond
- ((pairp(car wl))
- (setq wmm (cons nil wmm))
- (setq wll (cons (idxchg1!> (car wl) (car wm) (car wi)) wll)))
- (t (setq wll (cons (car wl) wll))
- (setq wmm (cons (car wm) wmm))))
- (setq wl (cdr wl))
- (setq wm (cdr wm))
- (setq wi (cdr wi)))
- (return (cons wll wmm))))
- (de idxchg1!> (wl wm wi)
- (cond ((spinp!> wi) (idxchg2!> wl wm))
- ((not(member wl '((0 0)(0 1)(1 0)(1 1)))) !!er!!)
- (t (setq wl (list2 (idch1!> (car wl) (car wm))
- (idch1!> (cadr wl) (cadr wm))))
- (cond ((equal wl '(0 0)) 1)
- ((equal wl '(1 1)) 0)
- ((equal wl '(0 1)) 3)
- ((equal wl '(1 0)) 2) ))))
- (de idch1!> (wl wm)
- (cond ((and wm (eqn wl 0)) 1)
- ((and wm (eqn wl 1)) 0)
- (t wl)))
- (de idxchg2!> (wl wm)
- (cond ((null wl) 0)
- ((car wm) (plus2 (cond ((zerop(car wl)) 1) (t 0))
- (idxchg2!> (cdr wl) (cdr wm))))
- (t (plus2 (car wl) (idxchg2!> (cdr wl) (cdr wm)))) ))
- % Index for data component translation ...
- (de indextr!> (w)
- (cond((null w) 0)
- ((not(zerop(car w))) (err!> 20231))
- ((or(not(numberp(setq w(nz!>(eval!>(cdr w))))))
- (lessp w 0)) (err!> 2102))
- (t w)))
- % Dummy variable evaluation ...
- (de dummyvar!> (w)
- (cond ((get w '!=subind) (prog2 (setq w (get w '!=subind))
- (cond((zerop w) nil)
- (t(cons 0 w)))))
- (t(prog2(doub!> w) (err!> 2018)))))
- % _| execution
- (de inpr!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((not(eqn(car lst1) -1)) (err!> 2002))
- ((eqn(car lst2) -1) (err!> 2003))
- ((eqn(car lst2) 0) (err!> 2003))
- ((eqn(car lst2) 1)
- (cona1!> 0 (vform1!>(cdr lst1)(cdr lst2))))
- (t(conf1!> (sub1(car lst2))
- (vform!>(cdr lst1)(cdr lst2))))))
- % | execution
- (de vef!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((not(eqn(car lst1) -1)) (err!> 20021))
- ((not(zerop(car lst2))) (err!> 20031))
- (t (cona1!> 0 (vfun!>(cdr lst1)(cdr lst2))))))
- % . execution
- (de vpr!> (lst1 lst2)
- (cond ((or (null lst1) (null lst2)) nil)
- ((and (eqn (car lst1) -1) (eqn (car lst2) -1))
- (require!> '( !#!T !#!G ))
- (cona1!> 0 (vprod!> (cdr lst1) (cdr lst2))) )
- ((and (eqn (car lst1) 1) (eqn (car lst2) 1))
- (require!> '( !#!D !#!G!I ))
- (cona1!> 0 (fprod!> (cdr lst1) (cdr lst2))) )
- ((and (eqn (car lst1) -1) (eqn (car lst2) 1))
- (cona1!> 0 (vform1!> (cdr lst1) (cdr lst2))) )
- ((and (eqn (car lst1) 1) (eqn (car lst2) -1))
- (cona1!> 0 (vform1!> (cdr lst2) (cdr lst1))) )
- (t (err!> 2030))))
- % d execution
- (de dx!> (lst)
- (cond ((null lst) nil)
- ((minusp(car lst)) (err!> 2004))
- ((and(eqn(car lst)0)(idp(cdr lst))(get(cdr lst) '!=cord))
- (cons 1 (cond(![umod!](getel1!> ![xf!] (get (cdr lst) '!=cord)))
- (t (mkdx!>(get (cdr lst) '!=cord))))))
- ((eqn(car lst) 0) (conf1!> 1(dfun!>(cdr lst))))
- (t(conf1!> (add1(car lst))
- (dex!>(cdr lst))))))
- % @ X execution
- (de bvec!> (lst)
- (cond ((null lst) nil)
- ((not(zerop(car lst))) (err!> 2013))
- ((and(idp(cdr lst))(get (cdr lst) '!=cord))
- (cons -1 (cond (![umod!]
- (getel1!> ![xv!] (get(cdr lst) '!=cord)))
- (t (mkdx!>(get (cdr lst) '!=cord))))))
- (t(err!> 2013))))
- % # execution
- (de dualis!> (lst)
- (cond ((null lst) nil)
- ((eqn (car lst) -1) (err!> 2007))
- ((eqn (car lst) 0) (prog2
- (require!> '(!#!V!O!L))
- (conf1!> ![dim!] (dual0!>(cdr lst)))))
- ((eqn (car lst) ![dim!]) (prog2
- (require!> '(!#!V!O!L))
- (cona1!> 0 (duald!>(cdr lst)))))
- (t (prog2
- (require!> '(!#!T !#!G !#!V!O!L))
- (conf1!> (difference ![dim!] (car lst)) (dual!>(cdr lst)))))))
- % / execution
- (de quoti!> (lst1 lst2)
- (cond ((null lst2) (err!> 2009))
- ((null lst1) nil)
- ((not(zerop(car lst2))) (err!> 2011))
- ((zerop(car lst1))
- (cona1!> 0 (list 'quotient (cdr lst1) (cdr lst2))))
- (t(conf1!> (car lst1)
- (fndfpr!> (list 'quotient 1 (cdr lst2))
- (cdr lst1))))))
- % + execution
- (de plus2!> (lst1 lst2)
- (cond((null(setq lst1(unieval!> lst1))) (unieval!> lst2))
- ((null(setq lst2(unieval!> lst2))) lst1)
- ((not(eqn(car lst1)(car lst2))) (err!> 2012))
- ((zerop(car lst1)) (cona1!> 0 (list 'plus(cdr lst1)(cdr lst2))))
- (t(conf1!>(car lst1)(dfsum!>(list2(cdr lst1)(cdr lst2)))))))
- % + execution
- (de plus!> (lst)
- (prog (w wt wa)
- (foreach!> x in lst do
- (cond((setq wa(unieval!> x))(progn
- (cond((null wt)(setq wt(car wa))))
- (cond((not(eqn wt(car wa))) (err!> 2012)))
- (setq w(cons(cdr wa)w))))))
- (return(cond((null w) nil)
- ((zerop wt)(cona1!> 0 (cons 'plus w)))
- (t(conf1!> wt (dfsum!> w)))))))
- % * execution
- (de times2!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((and(zerop(car lst1))(zerop(car lst2)))
- (cona1!> 0 (list 'times (cdr lst1)(cdr lst2))))
- ((and(zerop(car lst1))(not(zerop(car lst2))))
- (conf1!> (car lst2)(fndfpr!> (cdr lst1)(cdr lst2))))
- ((and(zerop(car lst2))(not(zerop(car lst1))))
- (conf1!> (car lst1)(fndfpr!> (cdr lst2)(cdr lst1))))
- (t (err!> 2010))))
- (de times22!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((or(null(setq lst1 (unieval!> lst1)))
- (null(setq lst2 (unieval!> lst2)))) nil)
- ((and(zerop(car lst1))(zerop(car lst2)))
- (cona1!> 0 (list 'times (cdr lst1)(cdr lst2))))
- ((and(zerop(car lst1))(not(zerop(car lst2))))
- (conf1!> (car lst2)(fndfpr!> (cdr lst1)(cdr lst2))))
- ((and(zerop(car lst2))(not(zerop(car lst1))))
- (conf1!> (car lst1)(fndfpr!> (cdr lst2)(cdr lst1))))
- (t (err!> 2010))))
- % - execution
- (de minus!> (lst)
- (cond ((null lst) nil)
- ((zerop(car lst)) (cons 0 (chsign!> nil (cdr lst))))
- (t(cons (car lst)(chsign!> t (cdr lst))))))
- % ~ execution
- (de co!> (lst)
- (cond ((null lst) nil)
- ((zerop(car lst)) (cons 0 (coalg!> (cdr lst))))
- ((eqn(car lst) -1) (cons -1 (covec!> (cdr lst))))
- (t(cons (car lst)(coform!> (cdr lst))))))
- % re=(expr+~expr)/2 execution
- (de re!> (lst)
- (cond((cdr lst) (err!> 2105))(t
- (times2!> '(0 quotient 1 2)
- (plus2!>(car lst)(co!>(car lst)))))))
- % expr+~~=expr+~expr execution
- (de re2!> (lst) (plus2!> lst (co!> lst)))
- % im=-i * (expr-~expr)/2 execution
- (de ima!> (lst)
- (cond((cdr lst) (err!> 2105))(t
- (times2!> '(0 quotient(minus i)2)
- (plus2!>(car lst)(minus!> (co!>(car lst))))))))
- % expr-~~ = expr-~expr execution
- (de im2i!> (lst) (plus2!> lst(minus!> (co!> lst))))
- % /\ execution
- (de dfpr2!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((or(lessp(car lst1)1)(lessp(car lst2)1)) (err!> 2005))
- (t(conf1!> (plus(car lst1)(car lst2))
- (dfprod2!> (cdr lst1)(cdr lst2))))))
- % [ , ] execution
- (de vbrc!> (lst1 lst2)
- (cond ((or(null lst1)(null lst2)) nil)
- ((or(not(minusp(car lst1)))(not(minusp(car lst2))))
- (err!> 2006))
- (t(conf1!> -1 (vbrack!> (cdr lst1)(cdr lst2))))))
- % ** execution
- (de exp!> (lst1 lst2)
- (cond((null lst1) nil)
- ((not(zerop(car lst1))) (err!> 2008))
- ((null lst2) '(0 . 1))
- ((not(zerop(car lst2))) (err!> 2008))
- (t(cona1!> 0 (list 'expt (cdr lst1)(cdr lst2))))))
- %---------- SUM translator. 08.01.91 -------------------------------------
- % SUM translation ...
- (de sumtr!> (lst)
- (prog (w)
- (setq lst(memlist!> '!, lst))
- (cond((eq lst !!er!!) (err!> 2020))
- ((null(cdr lst)) (err!> 2103)))
- (setq lst (reverse lst))
- (setq w (car lst))
- (setq lst (itercon!>(reverse(cdr lst))))
- (cond((eq lst !!er!!) (err!> 2103)))
- (setq lst (append lst (ncons w)))
- (return(sumtr1!> lst nil))))
- (de sumtr1!> (lst bool)
- (cond((null(cdr lst))(cond((eq bool 'func)(funtr!>(car lst)nil))
- ((eq bool 'term)(termtr1!>(car lst)))
- (t(unitra0!> lst))))
- (t(list 'sumexec!> (car lst)
- (sumtr1!> (cdr lst) bool)))))
- % SUM Execution ...
- (de sumexec!> (wi we)
- (proc (w wr)
- (setq wi(itertr!> wi (cond(![ivs!] (car ![ivs!]))(t t))))
- (while!> wi
- (put (caar wi) '!=subind (cdar wi))
- (setq ![ivs!] (cons (cdar wi) ![ivs!]))
- (setq wr (errorset!> (list 'plus2!> (list 'quote we)(list 'quote w))
- ![erst1!] ![erst2!]))
- (remprop (caar wi) '!=subind)
- (cond(![ivs!] (setq ![ivs!] (cdr ![ivs!]))))
- (cond((atom wr) (err!> wr)))
- (setq w (car wr))
- (setq wi(cdr wi)))
- (return w)))
- %---------- PROD translator 02.03.94 -------------------------------------
- % Prod Translation ...
- (de prodtr!> (lst)
- (prog (w)
- (setq lst(memlist!> '!, lst))
- (cond((eq lst !!er!!) (err!> 2020))
- ((null(cdr lst)) (err!> 2103)))
- (setq lst (reverse lst))
- (setq w (car lst))
- (setq lst (itercon!>(reverse(cdr lst))))
- (cond((eq lst !!er!!) (err!> 2103)))
- (setq lst (append lst (ncons w)))
- (return(prodtr1!> lst nil))))
- (de prodtr1!> (lst bool)
- (cond((null(cdr lst))(cond((eq bool 'func)(funtr!>(car lst)nil))
- ((eq bool 'term)(termtr1!>(car lst)))
- (t(unitra0!> lst))))
- (t(list 'prodexec!> (car lst)
- (prodtr1!> (cdr lst) bool)))))
- % PROD Execution ...
- (de prodexec!> (wi we)
- (proc (w wr)
- (setq wi(itertr!> wi (cond(![ivs!] (car ![ivs!]))(t t))))
- (setq w '(0 . 1))
- (while!> wi
- (put (caar wi) '!=subind (cdar wi))
- (setq ![ivs!] (cons (cdar wi) ![ivs!]))
- (setq wr (errorset!> (list 'times22!> (list 'quote we)(list 'quote w))
- ![erst1!] ![erst2!]))
- (remprop (caar wi) '!=subind)
- (cond(![ivs!] (setq ![ivs!] (cdr ![ivs!]))))
- (cond((atom wr) (err!> wr)))
- (setq w (car wr))
- (setq wi(cdr wi)))
- (return w)))
- %----- Iterator translation for SUM/PROD and Print -----------------------
- % Main Iterator translation ...
- (de itertr!> (lst wp)
- (prog (wa wc w)
- (setq wa (car lst))
- (setq wc (cdr lst))
- (cond((not(idp(car wa))) (err!> 21031))
- ((flagp (car wa) '!+grgvar)(msg!> 2109)))
- (cond
- ((null(cdr wa))(return(iditertr!> (car wa) wc wp))) % j or j1 or j02
- ((not(eq(cadr wa) '!=)) (err!> 21031))
- ((not(memq '!.!. (cddr wa))) % j = a
- (return(mkiter!> (car wa) 0 (boundtr!>(cddr wa)) wc wp)))
- (t(progn % j = a _ b
- (setq w (car wa))
- (setq wa (seek1!> (cddr wa) '!.!. ))
- (cond((or(null(car wa))(null(cdr wa))) (err!> 21031)))
- (return
- (mkiter!> w (boundtr!>(reverse(car wa)))
- (boundtr!>(cdr wa)) wc wp)))))))
- % Iterator in the form of single identifier j or j1 or j02 ...
- (de iditertr!> (wi wc wp)
- (prog (wa wd)
- (setq wa (explode2 wi))
- (cond ((not (liter (car wa))) (doub!> wi) (err!> 2104)))
- (setq wd (selid!> wa nil)) % wd - numbers wa - atom
- % we cut trailing ~ , we do not care about it ...
- (setq wd (wipe!~!> wd))
- (cond
- % j12d = 0 .. (dim-1)
- ((notalldig!> wd)
- (return (mkiter!> wi 0 ![dim1!] wc wp)))
- % j = 0 .. (dim-1)
- ((and (null wd) (get (car wa) '!=uc))
- (return (mkiter!> wi 0 ![dim1!] wc wp)))
- % abc = 0 .. length(abc)
- ((and (null wd) (get (car wa) '!=lc))
- (return (mkiter!> wi 0 (length wa) wc wp)))
- % j3 = 0 .. 3
- ((null (cdr wd))
- (return (mkiter!> wi 0 (compress wd) wc wp)))
- % j13 = 1 .. 3
- ((null(cddr wd))
- (progn (setq wa (compress (ncons (car wd))))
- (setq wd (compress (cdr wd)))
- (return (mkiter!> wi wa wd wc wp))))
- (t(err!> 2108)))))
- (de wipe!~!> (w)
- (cond ((null w) nil)
- ((eq (car w) '!~) nil)
- (t (cons (car w) (wipe!~!> (cdr w))))))
- (de notalldig!> (w)
- (cond ((null w) nil)
- ((not (digit (car w))) t)
- (t (notalldig!>(cdr w)))))
- % Bound translation ...
- (de boundtr!> (lst)
- (progn (cond((null lst) (err!> 21031)))
- (setq lst(translate!>(ncons lst)))
- (cond((eq lst !!er!!) (err!> ![er!]))
- ((null lst) 0)
- ((or(not(zerop(car lst)))
- (not(numberp(cdr lst))))
- (err!> 2108))
- (t(cdr lst)))))
- % Prepares Iterator ...
- (de mkiter!> (id wi wf wc wp) % wc-comparison with wp ...
- (proc (w) % wi wf - up/lo bounds ...
- (cond((lessp wf wi)(prog2(msg!> 2104)(return nil))))
- (loop!>
- (cond((or(null wc)(validit!> wi wc wp))
- (setq w(cons(cons id wi) w))))
- (exitif (eqn wi wf))
- (setq wi(add1 wi)))
- (return w)))
- % Compare by < > <= >= ...
- (de validit!> (wi wc wp)
- (cond ((eqn wc 1)(lessp wp wi))
- ((eqn wc 2)(greaterp wp wi))
- ((eqn wc 3)(leq wp wi))
- ((eqn wc 4)(geq wp wi))
- (t t)))
- %-------- LHS and RHS ----------------------------------------------------
- (de lhs0!> (lst)
- (prog2(setq ![lsrs!] nil)(list2 'lhs!> (unitra0!> lst))))
- (de rhs0!> (lst)
- (prog2(setq ![lsrs!] t)(list2 'rhs!> (unitra0!> lst))))
- (de lhs!> (w) (prog2 (setq ![lsrs!] nil) (unieval!> w)))
- (de rhs!> (w) (prog2 (setq ![lsrs!] t) (unieval!> w)))
- %--------- Asy Sy Cy expansion 6.03.94 -----------------------------------
- (de allcy!> (lst)
- (proc (wi w)
- (while!> lst
- (setq w (cons (ncons(append lst (reverse wi))) w))
- (setq wi (cons (car lst) wi))
- (setq lst (cdr lst)))
- (return w)))
- (de allasy!> (lst)
- (cond ((or(null lst)(null(cdr lst))) nil)
- ((null(cddr lst)) (all2y!> lst t))
- (t(add1y!> t (car lst) (allasy!>(cdr lst))))))
- (de allsy!> (lst)
- (cond ((or(null lst)(null(cdr lst))) nil)
- ((null(cddr lst)) (all2y!> lst nil))
- (t(add1y!> nil (car lst) (allsy!>(cdr lst))))))
- (de all2y!> (lst wt)
- (list2 (cons(list2(cadr lst)(car lst))wt)
- (ncons(list2(car lst)(cadr lst)))))
- (de add1y!> (wt w lst)
- (proc (wr)
- (while!> lst
- (setq wr (add11y!> wt w (car lst) wr))
- (setq lst (cdr lst)))
- (return wr)))
- (de add11y!> (wtt w wl wr)
- (proc (wt wi)
- (setq wt (cdr wl))
- (setq wl (car wl))
- (while!> wl
- (setq wr (cons (cons(app!> wi (cons w wl))wt) wr))
- (setq wt (cond(wtt(not wt))(t nil)))
- (setq wi (cons (car wl) wi))
- (setq wl (cdr wl)))
- (setq wr (cons (cons(app!> wi (cons w wl))wt) wr))
- (return wr)))
- (de expandsym!> (lst)
- (cond(!*expandsym (expandsym0!> lst))(t lst)))
- (de expandsym0!> (lst)
- (cond
- ((atom lst) lst)
- (t(prog (w)
- (while!> lst
- (cond
- ((memq (car lst) '(!A!s!y !S!y !C!y))(progn
- (cond((or(null(cdr lst))(atom(cadr lst)))(err!> 6200)))
- (setq w (cons (expandsym1!>(car lst)(cadr lst)) w))
- (setq lst (cdr lst))))
- (t(setq w (cons (expandsym0!>(car lst)) w))))
- (setq lst (cdr lst)))
- (return(reversip w))))))
- (de expandsym1!> (w lst)
- (proc (we we wi wr)
- (setq lst (memlist!> '!, lst))
- (cond((or(eq lst !!er!!)(null(cdr lst)))(err!> 6200)))
- (setq lst (reverse lst))
- (setq we (expandsym0!>(car lst)))
- (setq lst (mapcar (cdr lst) 'idorerr!>))
- (setq wi lst)
- (setq lst (cond((eq w '!A!s!y )(allasy!> wi))
- ((eq w '!S!y )(allsy!> wi))
- ((eq w '!C!y )(allcy!> wi))))
- (while!> lst
- (setq wr (cons (cond((cdar lst) '!-)(t '!+)) wr))
- (setq wr (cons (mkreplace!> (pair wi (caar lst)) we) wr))
- (setq lst (cdr lst)))
- (return(reversip wr))))
- (de idorerr!> (w)
- (cond((or(cdr w)(not(idp(car w))))(err!> 6200))
- (t(car w))))
- (de mkreplace!> (w lst)
- (cond((atom lst)
- (cond((setq w (assoc lst w))(cdr w))
- (t lst)))
- (t(proc (wr)
- (while!> lst
- (setq wr (cons (mkreplace!> w (car lst)) wr))
- (setq lst (cdr lst)))
- (return(reversip wr))))))
- %----------- DF in prefix form 05.96 ------------------------------------
- %(de pdftra!> (w) (invord!> w 'df))
- %(de dfptra!> (w) (invord!> w 'dfp))
- %(de invord!> (w wf)
- % (proc (wa wr)
- % (while!> w
- % (cond
- % ((eq (car w) '!,)
- % (setq wr (append (cons '!, (reverse wa)) wr))
- % (setq wa nil)
- % (setq w (cdr w)))
- % (t (setq wa (cons (car w) wa))
- % (setq w (cdr w)))))
- % (setq wr (append (reverse wa) wr))
- % (return (funtr!> (list2 wf wr) t))))
- %----------- Limits 6.03.94 --------------------------------------------
- %(de limtr!> (lst) (limtra!> nil lst))
- %(de limtrm!> (lst) (limtra!> 'm lst))
- %(de limtrp!> (lst) (limtra!> 'p lst))
- %(de limtra!> (wt lst)
- % (prog (wx wl)
- % (cond((not(or(flagp 'limit 'opfn)(get 'limit 'simpfn)))
- % (err!> 6201)))
- % (setq lst (memlist!> '!, lst))
- % (cond((or (eq lst !!er!!) (null(cdr lst)) (cddr lst)
- % (not(idp(caar lst))) (not(eq(cadar lst) '!-!>))
- % (null(caddar lst)))
- % (err!> 6202)))
- % (setq wx (caar lst))
- % (cond((not(flagp wx '!+grgvar))
- % (prog2(doub!> wx) (err!> 2018))))
- % (setq wl (unitra0!>(cddar lst)))
- % (setq lst (unitra0!>(cdr lst)))
- % (return(list 'limexec!> (list wx wl wt) lst))))
- %
- % wx - limiting var wl - limiting point wt - limit's type
- %(de limexec!> (ww lst)
- % (prog (wx wl wt)
- % (setq wx (car ww))
- % (setq wl (cadr ww))
- % (setq wt (caddr ww))
- % (setq wl (unieval!> wl))
- % (cond((or(null wl)(zerop wl))(setq wl 0))
- % ((not(zerop(car wl))) (err!> 6203))
- % (t(setq wl (cdr wl))))
- % (setq lst (unieval!> lst))
- % (return
- % (cond((null lst) nil)
- % ((zerop(car lst))(cona1!> 0 (lima!> wx wl wt (cdr lst))))
- % (t(conf1!>(car lst)(limf!> wx wl wt (cdr lst))))))))
- %------- SUBstitutions 7.03.94 -------------------------------------------
- (de subtr!> (lst)
- (prog (wl)
- (setq lst (memlist!> '!, lst))
- (cond((eq lst !!er!!) (err!> 6204)))
- (setq lst (reverse lst))
- (setq wl (cdr lst))
- (setq lst (unitra0!>(car lst)))
- (setq wl (mapcar wl 'subtr1!>))
- (setq wl (reversip wl))
- (return(list 'subexec!> wl lst))))
- (de subtr1!> (w)
- (prog (ww)
- (setq ww w)
- (setq w (seek1!> w '!=))
- (cond
- ((null w)
- (cond((or(atom ww)(not(eq (car ww) '!S!o!l))) (err!> 6204))
- (t(progn
- (setq w (soltra!> ww))
- (cond((eq w !!er!!)(err!> ![er!])))
- (return w)))))
- ((or (null(car w)) (null(cdr w))) (err!> 6204))
- (t(return(cons (unitraa!>(reverse(car w))) (unitra!>(cdr w))))))))
- (de subexec!> (wl lst)
- (cond((null(setq lst (unieval!> lst))) nil)
- ((zerop(car lst))
- (cona1!> 0 (subalg!>(mapcar wl 'subexec1!>)(cdr lst))))
- (t(conf1!>(car lst)(subdf!>(mapcar wl 'subexec1!>)(cdr lst))))))
- (de subexec1!> (w)
- (prog (ww)
- (cond((eq (car w) 'equal)(return w)))
- (setq ww (unieval!>(cdr w)))
- (cond((null ww)(setq ww nil))
- ((not(zerop(car ww))) (err!> 6205))
- (t(setq ww (cdr ww))))
- (return (list 'equal (nz!>(car w)) (nz!> ww)))))
- %------- If and boolean expressions. 19.03.94 ----------------------------
- (de iftran!> (lst)
- (cond
- ((eq (setq lst (memlist!> '!, lst)) !!er!!) (err!> 8200))
- ((eqn (length lst) 2) % if ... then ...
- (list 'ifexec!> (booltrai!>(car lst))
- (unitra0!>(cadr lst)) nil))
- ((eqn (length lst) 3) % if ... then ... else ...
- (list 'ifexec!> (booltrai!>(car lst))
- (unitra0!>(cadr lst))
- (unitra0!>(caddr lst)) ))
- (t(err!> 8200))))
- (de booltrai!> (lst)
- (cond ((atom lst) (atomtrabi!> lst)) % atom
- ((and(pairp lst)(null(cdr lst))) % next level
- (booltrai!>(car lst)))
- (t(prog (w) % or - translation ...
- (setq w (memlist!> '!o!r lst))
- (cond((eq w !!er!!) (err!> 2400))
- ((null(cdr w))(return(andtrai!> lst))))
- (return(list2 'orex!> (mapcar w 'andtrai!>)))))))
- (de andtrai!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltrai!>(car lst))) % next level
- (t(prog (w) % and - translation ...
- (setq w (memlist!> '!a!n!d lst))
- (cond((eq w !!er!!) (err!> 2400))
- ((null(cdr w))(return(nottrai!> lst)))) % bool function
- (return(list2 'andex!> (mapcar w 'nottrai!>)))))))
- (de nottrai!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltrai!>(car lst))) % next level
- ((and (idp(car lst)) (get (car lst) '!=boolmac))
- (list2 (get (car lst) '!=boolmac)
- (list2 'quote (cadr lst))))
- ((eq (car lst) '!n!o!t)
- (list2 'notex!> (reltrai!>(cdr lst))))
- (t(reltrai!> lst))))
- (de reltrai!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltrai!>(car lst))) % next level
- (t(prog (w wa wb)
- (setq w (seek!> lst '( != !< !> !<!= !>!= !|!= )))
- (cond((null w) (return(algtra1i!> lst)))
- ((or (null(car w)) (null(cddr w))) (err!> 2400)))
- (setq wa (unitra0!>(reverse(car w))))
- (setq wb (unitra0!>(cddr w)))
- (setq w (cadr w))
- (cond
- ((eq w '!=) (setq w 'equal))
- ((eq w '!<) (setq w 'lessp))
- ((eq w '!>) (setq w 'greaterp))
- ((eq w '!|!=) (setq w 'neq))
- ((eq w '!<!=) (setq w 'leq))
- ((eq w '!>!=) (setq w 'geq)))
- (return(list 'relex!> w wa wb))))))
- (de algtra1i!> (lst)
- (list 'balgex!> (unitra0!> lst)))
- (de atomtrabi!> (lst)
- (list 'balgex!> (atomtr!> lst)))
- (de ifexec!> (wc wa wb)
- (cond((booleval!> wc) (unieval!> wa))
- (t (unieval!> wb)) ))
- (de booleval!> (lst)
- (cond((or (atom lst) (numberp(car lst)) (pairp(car lst))) lst)
- ((and (idp(car lst)) (flagp (car lst) '!+specbexe))
- (eval lst))
- (t (apply (car lst) (mapcar (cdr lst) (function booleval!>))))))
- (de balgex!> (w)
- (cond((unievaluate!> w) t)
- (t nil)))
- (de orex!> (w)
- (proc nil
- (while!> w
- (cond((booleval!>(car w)) (return t)))
- (setq w (cdr w)))
- (return nil)))
- (de andex!> (w)
- (proc nil
- (while!> w
- (cond((null(booleval!>(car w))) (return nil)))
- (setq w (cdr w)))
- (return t)))
- (de notex!> (w) (not(booleval!> w)))
- (de n00!> (w) (cond(w w)(t '(0 . 0))))
- (de relex!> (w wa wb)
- (progn
- (setq wa (n00!>(unievaluate!> wa)))
- (setq wb (n00!>(unievaluate!> wb)))
- (cond((or (not(zerop(car wa))) (not(zerop(car wb)))
- (not(numberp(cdr wa))) (not(numberp(cdr wb))) )
- (err!> 8201)))
- (setq wa (cdr wa))
- (setq wb (cdr wb))
- (cond
- ((eq w 'equal) (eqn wa wb))
- ((eq w 'lessp) (lessp wa wb))
- ((eq w 'greaterp) (greaterp wa wb))
- ((eq w 'neq) (not(eqn wa wb)))
- ((eq w 'leq) (leq wa wb))
- ((eq w 'geq) (geq wa wb))
- )))
- (de prepiv!> (w)
- (cond ((or (not(pairp w)) (not(idp(car w)))) (err!> 2400))
- (t (incomiv!> (explode2(car w))))))
- (de prepsw!> (w)
- (cond ((or (not(pairp w)) (not(idp(car w)))) (err!> 2400))
- (t (makeswvar!>(car w)))))
- (de objexe!> (w)
- (prog2
- (setq w (prepiv!> w))
- (cond ((flagp w '!+ivar) t)
- (t nil))))
- (de onexe!> (w)
- (prog nil
- (setq w (prepsw!> w))
- (cond ((not(or (globalp w) (fluidp w))) (err!> 2420)))
- (return(eval w))))
- (de offexe!> (w)
- (prog nil
- (setq w (prepsw!> w))
- (cond ((not(or (globalp w) (fluidp w))) (err!> 2420)))
- (return(not(eval w)))))
- (de valexe!> (w)
- (prog nil
- (setq w (prepiv!> w))
- (cond ((not(flagp w '!+ivar)) (err!> 2410)))
- (return(eval w))))
- (de zeroexe!> (w)
- (prog nil
- (setq w (prepiv!> w))
- (cond ((not(flagp w '!+ivar)) (err!> 2410)))
- (return(equal (eval w) (mkbox!> w)))))
- (de nullexe!> (w)
- (prog nil
- (setq w (prepiv!> w))
- (cond ((not(flagp w '!+ivar)) (err!> 2410)))
- (return(equal (eval w)
- (cond ((pmmm!>) ![nullm1!])
- (t ![nullm!]))))))
- %----- User interrupt ----------------------------------------------------
- (de errortr!> (w) (list 'error!> w))
- (de error!> (w)
- (progn
- (cond ((pairp w) (setq w (car w))))
- (prin2 w)(terpri)
- (err!> 1000)))
- %----- Translation for Algebraic Expressions Only ------------------------
- % Without Evaluation for Let, Clear, Factor, RamFac, Ordaer ...
- % Translation with !!ER!! return for Algebraic Expressions only ...
- % dim sgnt sign - are replaced by exact numbers
- (de translata!> (lst)
- (prog nil
- (cond((null lst)(return nil)))
- (setq lst (errorset!> (list2 'unitraa!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- % The same but result must ne a pure number after EVAL!> ...
- (de ntranslata!> (lst)
- (prog nil
- (cond ((null lst) (return 0)))
- (setq lst (errorset!> (list2 'unitraa!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond ((atom lst) (setq ![er!] lst) (return !!er!!)))
- (setq lst (errorset!> (list2 'eval!> (list2 'quote (car lst)))
- ![erst1!] ![erst2!]))
- (cond ((atom lst) (setq ![er!] lst) (return !!er!!)))
- (setq lst (car lst))
- (cond ((null lst) (return 0))
- ((numberp lst) (return lst))
- (t (setq ![er!] 99) (return !!er!!))) ))
- % Alg translation ...
- (de unitraa!> (lst)
- (cond ((atom lst) (atomtra!> lst)) % atom
- ((and(pairp lst)(null(cdr lst)))(unitraa!>(car lst))) % next level
- (t(proc (w)
- (cond((not(memq(car lst) '(!+ !-))) % + - translation
- (setq lst(cons '!+ lst))))
- (setq w(mems!> '(!+ !-) (reverse lst) nil))
- (cond((eq w !!er!!) (err!> 2017)))
- (setq w(mapcar w 'auxfun3!>))
- (return(cond((null(cdr w))(car w))
- (t(cons 'plus w))))))))
- (de auxfun3!> (w)
- (cond((eq(cdr w) '!+)(termtra!>(car w)))
- (t(list2 'minus (termtra!>(car w))))))
- % Atom translation ...
- (de atomtra!> (w)
- (cond ((zerop w) nil) % zero
- ((stringp w)(prog2(doubs!> w) (err!> 2019)))
- ((eq w '!d!i!m) ![dim!]) % dimension
- ((or (eq w '!s!g!n!t) (eq w '!s!i!g!n)) ![sigprod!]) % signature
- ((or(numberp w)(flagp w '!+grgvar)) w) % number or variable
- (t(prog2(doub!> w) (err!> 2018)))))
- % * translation
- (de termtra!> (lst)
- (prog (w)
- (cond((null lst) (err!> 2016)))
- (setq w(seek1!> lst '!* ))
- (cond((null w) (return(quotra!> lst))))
- (return (list 'times
- (quotra!>(reverse(car w)))
- (termtra!>(cdr w))))))
- % / translation
- (de quotra!> (lst)
- (cond((null lst) (err!> 2016))
- ((not(memq '!/ lst))(exptra!> lst))
- (t(prog (w)
- (setq w(memlist!> '!/ lst))
- (cond((eq w !!er!!) (err!> 2016)))
- (return(quotmka!> nil w))))))
- (de quotmka!> (lst1 lst2)
- (cond((null lst2) lst1)
- (t(quotmka!>
- (list 'quotient
- (cond(lst1 lst1)(t(exptra!>(car lst2))))
- (exptra!>(cond(lst1(car lst2))(t(cadr lst2)))))
- (cond(lst1(cdr lst2))(t (cddr lst2)))))))
- % ** or ^ translation
- (de exptra!> (lst)
- (prog (w)
- (cond((null lst) (err!> 2016)))
- (setq w(seek!> lst '(!*!* !^) ))
- (cond((null w)(return(kertra!> lst))))
- (return (list 'expt
- (kertra!>(reverse(car w)))
- (exptra!>(cddr w))))))
- % Kernel translation
- (de kertra!> (lst)
- (cond((null lst) (err!> 2015))
- ((pairp(car lst))(cond((cdr lst) (err!> 2014))
- (t(unitraa!>(car lst)))))
- ((not(cdr lst)) (atomtra!>(car lst)))
- (t(funtra!> lst))))
- % Function translation
- (de funtra!> (lst)
- (cond((or(null lst)(atom lst)(not(eqn(length lst)2))
- (not(idp(car lst)))(atom(cadr lst)))
- (err!> 2021))
- ((and(not(flagp(car lst) '!+fun))
- (not(redgood!>(car lst))))
- (prog2(doub!>(car lst)) (err!> 2022)))
- (t(prog (w)
- (setq w (car lst))
- (setq lst(cadr lst))
- (setq lst(memlist!> '!, lst))
- (cond((eq lst !!er!!) (err!> 2020)))
- (setq lst (mapcar lst (function unitraa1!>)))
- (return(cons w lst))))))
- (de unitraa1!> (lst)
- (cond((setq lst (unitraa!> lst)) lst)
- (t 0)))
- %--------- Boolean Expressions Translation -------------------------------
- % For For All Such That ; command ...
- % Translation with !!ER!! return for Bollean Expressions ...
- (de booltra!> (lst)
- (prog nil
- (cond((null lst)(return nil)))
- (setq lst (errorset!> (list2 'booltra0!> (list2 'quote lst))
- ![erst1!] ![erst2!]))
- (cond((atom lst)(prog2(setq ![er!] lst)(return !!er!!))))
- (return(car lst)) ))
- (de booltra0!> (lst)
- (cond ((atom lst) (atomtrab!> lst)) % atom
- ((and(pairp lst)(null(cdr lst))) % next level
- (booltra0!>(car lst)))
- (t(prog (w) % or - translation ...
- (setq w (memlist!> '!o!r lst))
- (cond((eq w !!er!!) (err!> 2400))
- ((null(cdr w))(return(andtra!> lst))))
- (return(cons 'or (mapcar w 'andtra!>)))))))
- (de andtra!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltra0!>(car lst))) % next level
- (t(prog (w) % and - translation ...
- (setq w (memlist!> '!a!n!d lst))
- (cond((eq w !!er!!) (err!> 2400))
- ((null(cdr w))(return(nottra!> lst))))
- (return(cons 'and (mapcar w 'nottra!>)))))))
- (de nottra!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltra0!>(car lst))) % next level
- ((eq (car lst) '!n!o!t)
- (list2 'not (reltra!>(cdr lst))))
- (t(reltra!> lst))))
- (de reltra!> (lst)
- (cond ((null lst) (err!> 2400))
- ((null(cdr lst))
- (booltra0!>(car lst))) % next level
- (t(prog (w wa wb)
- (setq w (seek!> lst '( != !< !> !<!= !>!= !|!= )))
- (cond((null w) (return(algtra1!> lst)))
- ((or (null(car w)) (null(cddr w))) (err!> 2400)))
- (setq wa (algtra!>(reverse(car w))))
- (setq wb (algtra!>(cddr w)))
- (setq w (cadr w))
- (cond
- ((eq w '!=) (setq w 'evalequal))
- ((eq w '!<) (setq w 'evallessp))
- ((eq w '!>) (setq w 'evalgreaterp))
- ((eq w '!|!=) (setq w 'evalneq))
- ((eq w '!<!=) (setq w 'evalleq))
- ((eq w '!>!=) (setq w 'evalgeq)))
- (return(list w wa wb))))))
- (de algtra!> (lst)
- (list 'aeval (list 'quote (unitraa!> lst))))
- (de algtra1!> (lst)
- (list 'boolvalue!* (list 'eval!> (list 'quote (unitraa!> lst)))))
- (de atomtrab!> (lst)
- (list 'boolvalue!* (list 'eval!> (list 'quote (atomtra!> lst)))))
- %========= End of GRGtrans.sl ===========================================%
|