home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / TESTS / LF / GAUSS.LF < prev    next >
Text File  |  1996-06-04  |  11KB  |  362 lines
  1. op(500,xfy,\\)?
  2.  
  3. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  4.  
  5. % This file is a program written by Christophe Bonnet for his DEA.
  6. % It is an incremental equation solver using Gaussian elimination.
  7.  
  8. cpu_timehook -> 0.
  9. % cpu_timehook -> cpu_time.
  10.  
  11. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  12.  
  13. % FILE. . . . . /_/udir4/_/hassan/life/ok/quicksort
  14. % EDIT BY . . . Hassan Ait-Kaci
  15. % ON MACHINE. . Prlp22
  16. % STARTED ON. . Wed Jun 27 15:02:17 1990
  17.  
  18. q_sort(L,order => O) -> undlist(dqsort(L,order => O)).
  19.  
  20. undlist(X\\Y) -> X | Y=[].
  21.  
  22. dqsort([H|T],order => O) ->
  23.        (L1\\L2) & where((Less,More)  & split(H,T,([],[]),order => O),
  24.                        (L1 \\ [H|L3])& dqsort(Less,order => O),
  25.                        (L3 \\ L2)    & dqsort(More,order => O)).
  26. dqsort([]) -> L\\L.
  27.  
  28. split(X,[H|T],(Less,More),order => O) ->
  29.         cond(O(H,X),
  30.              split(X,T,([H|Less],More),order => O),
  31.              split(X,T,(Less,[H|More]),order => O)).
  32. split(@,[],P) -> P.
  33.  
  34. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  35.  
  36. % FILE. . . . . /_/udir4/_/bonnet/life/front.lf
  37. % EDIT BY . . . Christophe Bonnet
  38. % ON MACHINE. . Prl303
  39. % STARTED ON. . Wed Jul 22 18:54:33 1992
  40.  
  41. collector_starter(Q:q(@)) :- @=constraint_collector(Q).
  42. collector_starter(Q) :- failure_handler(Q).
  43.  
  44. constraint_collector(Q:q([E|S]))-> Cont
  45.                       | solve_constraint(E),
  46.                     Q <- q(S),
  47.                     Cont = constraint_collector(Q).
  48.  
  49. failure_handler(@) :- nl, write("=} I'm sorry, but I'm dying !"),nl,fail.
  50.  
  51. solve_constraint(gauss(L)) :- solve_eq(L),
  52.            write("==} solve          ",cpu_timehook),nl.
  53.  
  54.  
  55.  
  56. non_strict(feeder,fast_feeder,fast_starter)?
  57.  
  58. feeder(Eq,Q) :- Cstr=gauss(normalize(Eq)),Q=q([Cstr|@]).
  59.  
  60. fast_feeder([],@).
  61. fast_feeder([E|Tl],Q) :- feeder(E,Q), fast_feeder(Tl,Q).
  62.  
  63. fast_starter(EqList,Queue) :- Queue :== @,
  64.             collector_starter(Queue),
  65.             fast_feeder(EqList,Queue).
  66.  
  67. dynamic(varcount)?
  68. varcount -> 0.
  69. nvar -> vr(X,val=>none,wlist=>[])|X=varcount+1,setq(varcount,X).
  70.  
  71. create_vars([X|Tl]) :- X:==@,!,X=nvar,create_vars(Tl).
  72. create_vars([]).
  73.  
  74. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  75.  
  76. % FILE. . . . . /_/udir4/_/bonnet/life/norm.lf
  77. % EDIT BY . . . Christophe Bonnet
  78. % ON MACHINE. . Prl303
  79. % STARTED ON. . Wed Jul 15 17:58:51 1992
  80.  
  81. op(500,fx, ~ )?  % replace the unary minus
  82.  
  83. del(L:[@|Tl]) :- L <- Tl.
  84.  
  85. non_strict(nonstrict_id)?
  86. nonstrict_id(X,X).
  87.  
  88. normalize(E) -> N|expand(E,R),write("==} expand         ",cpu_timehook),nl,
  89.                   sort_and_reduce(R,N),
  90.                   write("==} reduce         ",cpu_timehook),nl.
  91.  
  92. % Non-verbose:
  93. % normalize(E) -> N|expand(E,R),sort_and_reduce(R,N).
  94.  
  95. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  96.  
  97. % FILE. . . . . /_/udir4/_/bonnet/life/expand.lf
  98. % EDIT BY . . . Christophe Bonnet
  99. % ON MACHINE. . Prl303
  100. % STARTED ON. . Wed Jul 15 17:57:49 1992
  101.  
  102. expand(W,R) :-  write("===} begin         ",cpu_timehook),nl,
  103.                 exp_no_minus(W,X),
  104.                 write("===} no_minus      ",cpu_timehook),nl,
  105.                 exp_dist(X,Y),
  106.                 write("===} dist          ",cpu_timehook),nl,
  107.                 exp_add_ac(Y,[],Z),
  108.                 write("===} add_ac        ",cpu_timehook),nl,
  109.                 exp_red_mult(Z,R),
  110.                 write("===} red_mult      ",cpu_timehook),nl.
  111. % Non-verbose:
  112. % expand(W,R) :-    exp_no_minus(W,X),
  113. %         exp_dist(X,Y),
  114. %         exp_add_ac(Y,[],Z),
  115. %         exp_red_mult(Z,R).
  116.  
  117. non_strict(exp_no_minus,exp_dist,exp_dist_do_add,exp_dist_do_mult)?
  118.  
  119. exp_no_minus(X) :- X :== @,
  120.     write("=} Variables must be created by the 'nvar' function."),!,fail.
  121. exp_no_minus(V:vr,V) :- !.
  122. exp_no_minus(A:real,A) :- !.
  123. exp_no_minus(~X,Z*X2) :- !,Z= -1,exp_no_minus(X,X2).
  124. exp_no_minus(X+Y,X2+Y2) :- !,exp_no_minus(X,X2),exp_no_minus(Y,Y2).
  125. exp_no_minus(X*Y,X2*Y2) :- !,exp_no_minus(X,X2),exp_no_minus(Y,Y2).
  126. exp_no_minus(X-Y,X2+Z*Y2) :- !,Z= -1,exp_no_minus(X,X2),exp_no_minus(Y,Y2).
  127.  
  128.  
  129. exp_dist(A:real,A):- !.
  130. exp_dist(V:vr,V) :- !.
  131. exp_dist(A+B,Z) :- !,exp_dist(A,X),exp_dist(B,Y),exp_dist_do_add(X+Y,Z).
  132. exp_dist((A+B)*C,Z) :- !,exp_dist(A*C+B*C,Z).
  133. exp_dist(A*(B+C),Z) :- !,exp_dist(A*B+A*C,Z).
  134. exp_dist(A*B,Z) :- exp_dist(A,X),exp_dist(B,Y),exp_dist_do_mult(X*Y,Z).
  135.  
  136. exp_dist_do_add(A:real + B:real,X) :- !, X= A+B.
  137. exp_dist_do_add(X,X).
  138.  
  139. exp_dist_do_mult(X:((A+B)*@),Y) :- !,exp_dist(X,Y).
  140. exp_dist_do_mult(X:(@*(A+B)),Y) :- !,exp_dist(X,Y).
  141. exp_dist_do_mult(A:real * B:real,X) :- !,X= A*B.
  142. exp_dist_do_mult(X,X).
  143.  
  144. non_strict(exp_add_ac,exp_red_mult,exp_red_mult_term,exp_red_mult_vars)?
  145.  
  146. %exp_add_ac(V:vr,V) :- !.
  147. %exp_add_ac(A:real,A) :- !.
  148. %exp_add_ac(X:@*@,X) :- !.
  149. %exp_add_ac(A:(@+@)+(B+C),Z) :- !,exp_add_ac(A+B+C,Z).
  150. %exp_add_ac(A+B,B+Z) :- exp_add_ac(A,Z).
  151.  
  152. exp_add_ac(A:(@+@)+B:(@+@),S,R) :- !,exp_add_ac(B,[A|S],R).
  153. exp_add_ac(A:(@+@)+B,S,B+R) :- !,exp_add_ac(A,S,R).
  154. exp_add_ac(A+B,[C|S],A+(B+R)) :- !,exp_add_ac(C,S,R).
  155. exp_add_ac(X,[],X).
  156.  
  157. exp_red_mult(A+B,K*V+S) :- !,exp_red_mult_term(A,K,V),exp_red_mult(B,S).
  158. exp_red_mult(A,K*V) :- exp_red_mult_term(A,K,V).
  159.  
  160. exp_red_mult_term(V:vr,1,V) :- !.
  161. exp_red_mult_term(K:real,K,1) :- !.
  162. exp_red_mult_term(A*B,K,V) :-
  163.     exp_red_mult_term(A,K1,V1),
  164.     exp_red_mult_term(B,K2,V2),
  165.     K=K1*K2,exp_red_mult_vars(V1,V2,V).
  166.  
  167. exp_red_mult_vars(1,V,V) :- !.
  168. exp_red_mult_vars(V,1,V) :- !.
  169. exp_red_mult_vars(V1,V2,V1*V2).
  170.  
  171. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  172.  
  173. % FILE. . . . . /_/udir4/_/bonnet/life/reduce.lf
  174. % EDIT BY . . . Christophe Bonnet
  175. % ON MACHINE. . Prl303
  176. % STARTED ON. . Thu Jul 16 14:32:16 1992
  177.  
  178. sort_and_reduce(X,R) :-
  179.     sum2slist(X,Y),
  180.     Z=var_q_sort(Y),
  181.     slist_reduce(Z,R),
  182.     deg_chk(R).
  183.  
  184. non_strict(varless,varless_pred,var_q_sort) ?
  185.  
  186. varless_pred(@*vr,@*real) :- !.
  187. varless_pred(@*vr,real) :- !.
  188. varless_pred(@*vr(X),@*vr(Y)) :- !,X<Y.
  189. varless_pred(@*(@*@),@).
  190.  
  191. varless(X,Y) -> call_once(varless_pred(X,Y)).
  192.  
  193. non_strict(sum2slist,deg_chk,slist_reduce)?
  194.  
  195.  
  196. sum2slist(T+S,[T|R]) :- !,sum2slist(S,R).
  197. sum2slist(P:(@*@),[P]) :- !.
  198. sum2slist(A:real,[A]) :- !.
  199. sum2slist(V:vr,[V]).
  200.  
  201. deg_chk([]) :- !.
  202. deg_chk([real|T]) :- !,deg_chk(T).
  203. deg_chk([real*vr|T]) :- !,deg_chk(T).
  204. deg_chk(@) :- fail.
  205.  
  206. % load(quicksort)?
  207.  
  208. var_q_sort(E) -> q_sort(E,order=>varless).
  209.  
  210. slist_reduce([0*@|T],R) :- !,slist_reduce(T,R).
  211. slist_reduce([A*(X:vr(N)),B*vr(N)|T],R) :- C= A+B,!,slist_reduce([C*X|T],R).
  212. slist_reduce([A*1],[A]) :- !.
  213. slist_reduce([H|T],[H|R]) :- !,slist_reduce(T,R).
  214. slist_reduce([],[0]).
  215.  
  216. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  217.  
  218. % FILE. . . . . /_/udir4/_/bonnet/life/solver.lf
  219. % EDIT BY . . . Christophe Bonnet
  220. % ON MACHINE. . Prl303
  221. % STARTED ON. . Mon Jul 20 18:02:01 1992
  222.  
  223. non_strict(solve_eq,mult_eq,div_eq,do_subst,wake_up)?
  224.  
  225. solve_eq([0]) :- !.                        %succes
  226. solve_eq([real]) :- !,fail.                    %failure
  227. solve_eq([A*X:vr(val=>none)|L]) :- !,inst_var(X,L,A),            %"pivot"
  228.                 write("===} inst_var      ",cpu_timehook),nl.
  229. solve_eq([A*vr(val=>V)|L]) :- ML=mult_eq(V,A),            %substit
  230.                   slist_merge(ML,L,NL), 
  231.                 write("===} slist_merge   ",cpu_timehook),nl,
  232.                   solve_eq(NL).
  233. % Non-verbose:
  234. % solve_eq([A*X:vr(val=>none)|L]) :- !,inst_var(X,L,A).            %"pivot"
  235. % solve_eq([A*vr(val=>V)|L]) :- ML=mult_eq(V,A),        %substit
  236. %                   slist_merge(ML,L,NL), 
  237. %                   solve_eq(NL).
  238.  
  239. div_eq([A:real],B) -> [-A/B].
  240. div_eq([A*X|Tl],B) -> [(`(Z*X))|div_eq(Tl,B)] | Z= -A/B.
  241.  
  242. mult_eq([A:real],B) -> [A*B].
  243. mult_eq([A*X|Tl],B) -> [(`(Z*X))|mult_eq(Tl,B)] | Z=A*B.
  244.  
  245. inst_var(X:vr(val=>V,wlist=>W),Eq,A) :- do_subst(Eq,NewEq),
  246.                 write("====} do_subst     ",cpu_timehook),nl,
  247.                     V <- div_eq(NewEq,A),
  248.                     wake_up(W,V),
  249.                 write("====} wake_up      ",cpu_timehook),nl,
  250.                     update_vars(X,V),
  251.                     W <- [].
  252. % Non-verbose:
  253. % inst_var(X:vr(val=>V,wlist=>W),Eq,A) :- do_subst(Eq,NewEq),
  254. %                     V <- div_eq(NewEq,A),
  255. %                     wake_up(W,V),
  256. %                     update_vars(X,V),
  257. %                     W <- [].
  258.  
  259. do_subst(X:[real],X) :- !.
  260. do_subst([T:(A*vr(val=>none))|L],[T|NL]) :- do_subst(L,NL).
  261. do_subst([T:(A*vr(val=>V))|Tl],NV) :- ML=mult_eq(V,A),
  262.                       slist_merge(ML,Tl,NL),
  263.                       do_subst(NL,NV).
  264.  
  265. wake_up([],@) :- !.
  266. wake_up([gauss_wup(lhs_var=>X,term_ptr=>P:[A*@|@])|WL],Val) :-
  267.     del(P),
  268.     recompute(X,A,Val),
  269.     wake_up(WL,Val).
  270.  
  271. recompute(X:vr(Id,val=>Oldval),Coef,Sval) :-
  272.         ML=mult_eq(Sval,Coef),
  273.         s_merge(ML,Oldval,Newval,PtL),
  274.         update_newvars(X,PtL),
  275.         X <- vr(Id,val=>Newval,wlist=>[]).
  276.  
  277.  
  278. non_strict(update_vars,update_newvars,upd_vars)?
  279.  
  280. update_vars(@,[A:real]) :- !.
  281. update_vars(X,Ptr:[@*Y|Tl]) :-
  282.     upd_var(Y,X,Ptr),
  283.     update_vars(X,Tl).
  284.  
  285. update_newvars(@,[]) :- !.
  286. update_newvars(X,[Ptr:[@*Y|@]|Tail]) :-
  287.     upd_var(Y,X,Ptr),
  288.     update_newvars(X,Tail).
  289.  
  290. upd_var(Y:vr(Id,wlist=>WL),X,Ptr) :- Y <- vr(Id,
  291.                          val=>none,
  292.                          wlist=>[gauss_wup(lhs_var=>X,
  293.                                    term_ptr=>Ptr)
  294.                              |WL]).
  295.  
  296. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  297.  
  298. % FILE. . . . . /_/udir4/_/bonnet/life/merge.lf
  299. % EDIT BY . . . Christophe Bonnet
  300. % ON MACHINE. . Prl303
  301. % STARTED ON. . Wed Jul 22 15:31:15 1992
  302.  
  303. non_strict(slist_merge)? % 23.9
  304.  
  305. slist_merge([],L,L) :- !.
  306. slist_merge(L,[],L) :- !.
  307. slist_merge([A:real],[B:real],[C]) :-  !,C=A+B.
  308. slist_merge([A|L1],L2:[B|@],[A|L3]) :-
  309.     varless_pred(A,B), !,
  310.     slist_merge(L1,L2,L3).
  311. slist_merge(L1:[A|@],[B|L2],[B|L3]) :-
  312.     varless_pred(B,A),!,
  313.     slist_merge(L1,L2,L3).
  314. slist_merge([(A:real)*(V:vr(Id))|L1],[(B:real)*vr(Id)|L2],Z) :-
  315.     C= A+B,
  316.     nonstrict_id(T,C*V),
  317.     Z=cond(null(C),L3,[T|L3]),
  318.     slist_merge(L1,L2,L3).
  319.  
  320. null(0)->true.
  321. null -> false.
  322.  
  323. % les deux premiers arguments de s_merge sont les slists a combiner,
  324. % le troisieme est le resultat, le 4eme la liste des sous_listes du resultat
  325. % dont le premier element vient de la premiere liste. En d'autres termes, c'est
  326. % la liste des cellules de listes que l'on a creees.
  327.  
  328. s_merge([A|L1],L2:[B|@],L3:[A|L2],[L3|PtL]) :-
  329.     varless_pred(A,B), !,
  330.     s_merge2(L1,L3,PtL).
  331. s_merge(L1,L2,L2,PtL) :- s_merge2(L1,[@|L2],PtL).
  332.  
  333. s_merge2([],@,[]) :- !.    
  334. s_merge2(L,[@|X:[]],L) :- !,X <- L.
  335. s_merge2([A:real],[@,B:real],[]) :- !,B <- A+B.
  336. s_merge2([A|L1],LP:[U|L2:[B|@]],[L3|PtL]) :-
  337.     varless_pred(A,B), !,
  338.     LP <- [U|L3:[A|L2]],
  339.     s_merge2(L1,L3,PtL).
  340.  
  341. non_strict(s_merge2)?
  342.  
  343. s_merge2(L1:[A|@],[@|L2:[B|@]],PtL) :-
  344.     varless_pred(B,A), !,
  345.     s_merge2(L1,L2,PtL).
  346. s_merge2([(A:real)*vr(Id,wlist=>WL)|L1],LP:[@|L2:[(B:real)*vr(Id)|@]],PtL) :-
  347.     A+B = 0, !,
  348.     clean_wlist(WL,L2),
  349.     del(L2),
  350.     s_merge2(L1,LP,PtL).
  351. s_merge2([(A:real)*vr(Id)|L1],[@|L2:[(B:real)*vr(Id)|@]],PtL) :-
  352.     B <- A+B,
  353.     s_merge2(L1,L2,PtL).
  354.  
  355. clean_wlist([],@).
  356. clean_wlist(WL:[gauss_wup(term_ptr=>L1)|@],L2) :- L1===L2,!,del(WL).
  357. clean_wlist([@|WL],L) :- clean_wlist(WL,L).
  358.  
  359. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  360.  
  361. where->@.
  362.