home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / TESTS / LF / CB.LF < prev    next >
Text File  |  1996-06-04  |  4KB  |  158 lines
  1. op(600,xfx,<:)?
  2.  
  3. op(525,xfy,**)?
  4.  
  5. op(500,xfy,\\)?
  6.  
  7. %%%%%%%%%%%
  8. % variables
  9.  
  10. % ::vr(int).
  11.  
  12. dynamic(varcount,elim)?
  13.  
  14. varcount -> 0.
  15.  
  16. nvar -> vr(X:(varcount+1)) | setq(varcount,X).
  17. % vr(0) n'est jamais utilisee. Le terme en vr(0) d'une equation correspond
  18. % au terme constant.
  19. vr(0) <: _ :- !,fail.
  20. _ <: vr(0) :- !.  
  21. vr(X) <: vr(Y) :- elim(X),elim(Y),X<Y.
  22. vr(X) <: vr(Y) :- \+(elim(X)),\+(elim(Y)),X<Y.
  23. vr(X) <: vr(Y) :- elim(X),\+(elim(Y)).
  24.  
  25.  
  26. %%%%%%%%%%%
  27. % normalize
  28.  
  29. normalize(E) -> N | expand(E,R),regroup(sort_vars(R),S),kill_zeroes(S,N),!.
  30.  
  31. kill_zeroes([],[]).
  32. kill_zeroes([0**_|M],N) :- !, kill_zeroes(M,N).
  33. kill_zeroes([T:(A**X)|M],[T|N]) :- kill_zeroes(M,N).
  34.  
  35. regroup([],[]).
  36. regroup([A**X,B**X|M],R) :- !, regroup([A+B**X|M],R).
  37. regroup([T|M],[T|N]) :- regroup(M,N).
  38.  
  39. sort_vars(E) -> q_sort(E,order=>varless).
  40.  
  41. varless(_**V1,_**V2) ->  call_once(V1 <: V2).
  42.  
  43. expand([],[]).
  44. expand([A**[B**X|M]|N],R) :- expand([A*B**X,A**M|N],R).
  45. expand([A**[]|M],R) :- expand(M,R).
  46. expand([A**V:vr|M],[A**V|N]) :- expand(M,N).
  47.  
  48. %%%%%%%%%
  49. % ordonne
  50.  
  51. sysless(V1=_,V2=_) -> call_once(V1 <: V2).
  52.  
  53. ordonne(Syst)  -> q_sort(Syst,order=>sysless).
  54.  
  55.  
  56. remet([],L) -> L.
  57. remet([A|L1],L2) -> remet(L1,[A|L2]).
  58.  
  59. normsys([]) -> [].
  60. normsys([A|T]) -> [normalize(A) | normsys(T)].
  61.  
  62. %%%%%%%%%%%%%%%%%%
  63. % le principal ...
  64.  
  65. % la structure de  travail est :
  66. % @(res1=>[...]          (listes d'eqs resolues deja utilisees)
  67. %   res2=>[...]        (listes d'eqs resolues non utilisees)
  68. %   nonres=>[...])    (eqs a resoudres)
  69.  
  70.   % echec
  71. reduit(@(nonres=>[[_**vr(0)]|_]),_) :- !, fail.
  72.  
  73.   % entails
  74. reduit(@(res1=>R1,res2=>R2,nonres=>[[] | Tail]),R) :- !,
  75.     reduit(@(res1=>[],res2=>remet(R1,R2),nonres=>Tail),R).
  76.  
  77.   % fin
  78. reduit(@(res1=>R1,res2=>R2,nonres=>[]), remet(R1,R2)).
  79.  
  80.   % elimination
  81. reduit(@(res1=>R1,res2=>[E:(X=M) | R2],nonres=>[[A**X | M2]|Tail]),R) :- !,
  82.     Eq=normalize([A**M | M2]),
  83.     reduit(@(res1=>[E | R1],res2=>R2,nonres=>[Eq | Tail]),R).
  84.  
  85.  
  86.   % skip
  87. reduit(@(res1=>R1,res2=>[E:(X=M) | R2],nonres=>S:[[A**Y | M2]|Tail]),R) :- !,
  88.     Y<:X,
  89.     reduit(@(res1=>[E | R1],res2=>R2,nonres=>S),R).
  90.  
  91.   % pivot
  92. reduit(@(res1=>R1,res2=>[],nonres=>[[A**X | M]|Tail]),R) :- !,
  93.     \+(X=vr(0)),!,
  94.     assert(elim(X)),
  95.     reduit(@(res1=>R1,res2=>[X=normalize([(-1/A)**M])],nonres=>Tail),R).
  96.  
  97.  
  98.  
  99. gauss(Sys,Nonres) -> R | 
  100.     Nres=normsys(Nonres),
  101.     reduit(@(res1=>[],res2=>Sys,nonres=>Nres),R).
  102.  
  103.  
  104.  
  105. %%%%%%%%%%%
  106. % exemples
  107.  
  108. e -> [2**Z , 3**[2**X , 5**[4**X , 2**Z] , (-2)**Y] , 2**[3**Y]]
  109.    | X = nvar, Y = nvar, Z = nvar.
  110.  
  111. i -> vr(0).
  112. s ->[[2**X,3**i],[2**X]]| X=nvar.
  113. s3 ->[[3**X,3**i],[1**X,1**i]]| X=nvar.
  114.  
  115. matrice_to_sys(M:[V|_]) -> 
  116.     aux_make_sys(mat=>M,
  117.              vars=>create_vvars(N-1))
  118.         | N:length(V)>0.
  119.  
  120. create_vvars(0)->[i].
  121. create_vvars(N)->[nvar|create_vvars(N-1)].
  122.  
  123. aux_make_sys(mat=>[]) -> [].
  124. aux_make_sys(mat=>[L|T],vars=>V) -> 
  125.     [aux_make_eq(line=>L,vars=>V)|aux_make_sys(mat=>T,vars=>V)].
  126.  
  127. aux_make_eq(line=>[])-> [].
  128. aux_make_eq(vars=>[])-> @ | write("echec"),fail.
  129. aux_make_eq(line=>[A|T1],vars=>[V|T2]) ->
  130.     [A**V|aux_make_eq(line=>T1,vars=>T2)].
  131.  
  132. matrice->[[1,3,4,0],[5,6,0,7]].
  133.  
  134.  
  135. test(gauss([],matrice_to_sys([ [2,5,2,1], [-1,3,0.5,2], [1,1,1,4] ]))).    
  136.  
  137.  
  138. %%%%%%%%%%%%
  139. % quicksort
  140.  
  141. q_sort(L,order => O) -> undlist(dqsort(L,order => O)).
  142.  
  143. undlist(X\\Y) -> X | Y=[].
  144.  
  145. dqsort([H|T],order => O) ->
  146.        (L1\\L2) & where((Less,More)  & split(H,T,([],[]),order => O),
  147.                        (L1 \\ [H|L3])& dqsort(Less,order => O),
  148.                        (L3 \\ L2)    & dqsort(More,order => O)).
  149. dqsort([]) -> L\\L.
  150.  
  151. split(X,[H|T],(Less,More),order => O) ->
  152.         cond(O(H,X),
  153.              split(X,T,([H|Less],More),order => O),
  154.              split(X,T,(Less,[H|More]),order => O)).
  155. split(@,[],P) -> P.
  156.  
  157. where -> @.
  158.