(* Parallele Kombinatormaschine + Implementierung der PR*)
fun last l = hd(rev l);
fun remove x [] = []
   |remove x (hd::tl) =
	if x = hd then remove x tl
        else hd::(remove x tl);
(* ****************** *)
datatype Emark = Eval|Busy|Ready;
datatype node = atom of (value * Emark ref * (node ref list) ref)
               |comb of (comb  * Emark ref * (node ref list) ref)
               |app of  ((node ref * node ref) * Emark ref * 
                                             (node ref list) ref);
fun alloc snode =
 let
   fun allocate (satom(x)) = atom(x,ref Ready, ref [])
      |allocate (scomb(com)) = comb(com,ref Ready, ref [])
      |allocate (sapp(a,b)) = app((ref (allocate a),ref (allocate b)),
                                  ref Eval, ref [])
 in
   ref(allocate snode)
 end;
fun dealloc (ref (atom(x,_,_))) = satom(x)
   |dealloc (ref (comb(k,_,_))) = scomb(k)
   |dealloc (ref (app((a,b),_,_))) = sapp(dealloc a,dealloc b);
fun is_atom (atom(_)) = true
   |is_atom (comb(_)) = false
   |is_atom (app(_))  = false;
fun is_app (atom(_)) = false
   |is_app (comb(_)) = false
   |is_app (app(_))  = true;
fun copy (ref(atom(x,ref Emark,ref wq))) = 
        ref(atom(x,ref Emark,ref wq))
   |copy (ref(comb(x,ref Emark,ref wq))) = 
        ref(comb(x,ref Emark,ref wq))
   |copy (ref(app((rator,rand),ref Emark,ref wq))) =
        ref(app((copy rator,copy rand),ref Emark,ref wq));
fun equal (ref(atom(x,_,_))) (ref(atom(y,_,_))) = (x=y)
   |equal (ref(comb(x,_,_))) (ref(comb(y,_,_))) = (x=y)
   |equal (ref(app((xrator,xrand),_,_))) 
          (ref(app((yrator,yrand),_,_))) =
        (equal xrator yrator) andalso (equal xrand yrand)
   |equal _ _ = false;
fun get_mark (ref(atom(_,m,_))) = m
   |get_mark (ref(comb(_,m,_))) = m
   |get_mark (ref( app(_,m,_))) = m; 
fun get_q (ref(atom(_,_,q))) = q
   |get_q (ref(comb(_,_,q))) = q
   |get_q (ref( app(_,_,q))) = q; 
fun set_q (ref(atom(_,_,q))) x = q:=x
   |set_q (ref(comb(_,_,q))) x = q:=x
   |set_q (ref( app(_,_,q))) x = q:=x; 
val ENV = ref [] : (string * node ref) list ref;
fun define name value = 
	ENV := (name, alloc(ropt(c(read value))))::(!ENV);
exception Lookup;
fun lookup name =
let
 fun lookup1 name [] = raise Lookup
    |lookup1 name ((x,y)::rest) = if name=x then y 
                                else (lookup1 name rest)
in
 lookup1 name (!ENV)
end;
fun spine (ref(atom(a,m,q))) stack = (atom(a,m,q),stack)
   |spine (ref(comb(c,m,q))) stack = (comb(c,m,q),stack)
   |spine (node as (ref(app((l,r),_,_)))) stack = spine l (node::stack);
val Tasks = ref [] : node ref list ref;
val Taskcounter = ref 0;
fun newTask task = 
   (Taskcounter := 1+(!Taskcounter);
    Tasks := (task::(! Tasks)));
fun remTask task =
   Tasks := (remove task (! Tasks));
fun make_wait node =
 let
  val (k,(w::_)) = spine node [];
  val ref(app((ref rator,rand),_,q)) = w;
 in
  w := app((ref(app((ref(comb(WAIT,ref Eval,ref [])),
                     ref rator),ref Eval,q)),
            rand),ref Eval,q)
 end;
  fun make_unwait node =
   let
    val (_,w::_) = spine node [];
    val ref(app((ref c,ref k),_,_)) = w;
    fun iswait (app(_,_,_)) = false
       |iswait (atom(_,_,_)) = false
       |iswait (comb(c,_,_)) = if (c=WAIT orelse c=WAIT1)
			       then true else false;
   in
    if iswait(c) 
      then w := k
      else () 
   end;
fun wakeup waitQ =
  (map (fn task => (make_unwait task))
       (! waitQ);
   waitQ := []);
fun subEval (root,node) =
 let 
  val emark = get_mark node;
  val wq = get_q node;
 in
  if (! emark = Ready) then ()
  else if (! emark = Busy) then
   (make_wait root;
    wq := root::(! wq))
  else
   (make_wait root;
    emark := Busy;
    wq := root::(!wq);
    newTask node)
  end;
fun parEval (root,node) =
 let 
  val emark = get_mark node;
  val wq = get_q node;
 in
  if (! emark = Ready) then ()
  else if (! emark = Busy) then
   (make_wait root;
    wq := root::(! wq))
  else
   (emark := Busy;
    newTask node)
  end;
fun apply (WAIT,(node as ref(app((_,x),m,q)))::_) =
        node := app((ref(comb(WAIT1,ref Ready,ref [])),
                     x),m,q)
   |apply (WAIT1,(node as ref(app((_,x),m,q)))::_) =
        node := app((ref(comb(WAIT,ref Ready,ref [])),
                     x),m,q)
   |apply (I,(node as ref(app((_,ref x),_,ref q)))::_) =
        (node := x; set_q node q)
   |apply (K,ref(app((_,ref x),_,ref q))::(node as ref(app(_,_,_)))::_) =
        (node := x; set_q node q)
   |apply (S,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
              ::(node as (ref(app((_,z),m,q))))::_) =
        node := app((ref(app((x,z),ref Eval,q)),
                     ref(app((y,z),ref Eval,q))),
                    ref Eval,q)
   |apply (B,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
              ::(node as (ref(app((_,z),m,q))))::_) =
	node := app((x,ref (app((y,z),ref Eval,q))),ref Eval,q)
   |apply (C,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
              ::(node as (ref(app((_,z),m,q))))::_) =
	node := app((ref(app((x,z),ref Eval,q)),y),ref Eval,q)
   |apply (Y,(node as ref(app((_,f),m,q)))::_) =
        node := app((f,node),ref Eval,q)
   |apply (DEF(name),(node as ref(app((_,_),_,_)))::_) =
        node := !(copy(lookup name))
   |apply (PLUS,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as 
                ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
        node := atom(int(x+y),ref Ready,q)
   |apply (PLUS,(stack as ref(app((_,x),_,_))::
                          ref(app((_,y),_,_))::_)) =
        (subEval (last stack,x);
         subEval (last stack,y); ())
   |apply (MINUS,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as 
                 ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
        node := atom(int(x-y),ref Ready,q)
   |apply (MINUS,(stack as ref(app((_,x),_,_))::
                          ref(app((_,y),_,_))::_)) =
        (subEval (last stack,x);
         subEval (last stack,y); ())
   |apply (TIMES,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as 
                 ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
        node := atom(int(x*y),ref Ready,q)
   |apply (TIMES,(stack as ref(app((_,x),_,_))::
                          ref(app((_,y),_,_))::_)) =
        (subEval (last stack,x);
         subEval (last stack,y); ())
   |apply (DIV,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as 
               ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
        node := atom(int(x div y),ref Ready,q)
   |apply (DIV,(stack as ref(app((_,x),_,_))::
                          ref(app((_,y),_,_))::_)) =
        (subEval (last stack,x);
         subEval (last stack,y); ())
   |apply (EQ,(stack as ref(app((_,x),_,_))::(node as
                          ref(app((_,y),_,q)))::_)) =
        if (!(get_mark x)) = Ready andalso
           (!(get_mark y)) = Ready 
          then node := atom(bool(equal x y),ref Ready,q)
        else
          (subEval (last stack,x);
          subEval (last stack,y); ())
   |apply (IF,(ref(app((_,ref(atom(bool test,_,_))),_,_))):: 
              (ref(app((_,x),_,_)))::(node as (ref(app((_,y),_,_))))::_) =
        if test then node := !x
        else node := !y
   |apply (IF,(stack as (ref(app((_,test),_,_)):: 
              ref(app((_,x),_,_))::(node as ref(app((_,y),_,q)))::_))) =
        subEval (last stack,test)
   |apply (CONS,_) = ()
   |apply (COPY,(node as ref(app((_,x),_,_)))::_) =
        node := !(copy x)
   |apply (PR, (stack as ( ref(app((_,f),_,_))::
                           ref(app((_,g),_,_))::
                           ref(app((_,xf),_,_))::(node as
                          (ref(app((_,xg),_,q))))::_))) =
        let
         val first =  ref(app((f,xf),ref Eval,ref []));
         val second = ref(app((g,xg),ref Eval,ref []));
        in
         (node := app((ref(app((ref(comb(CONS,ref Ready,ref [])),
                                first),ref Ready,ref [])),
                       second),ref Ready,q);
          parEval (last stack, first);
          parEval (last stack, second))
 	end
   |apply _ = ();
fun step node =
   let
    val (c,stack) = (spine node []);
   in
    if is_atom c then ()
    else let val comb(k,_,_)= c 
         in apply (k,stack) 
         end
   end;
fun evalstep (node as ref(atom(_,Emark,WQ))) = 
		(wakeup WQ;
		 remTask node;
		 Emark := Ready)
   |evalstep (node as ref(comb(_,Emark,WQ))) = 
		(wakeup WQ;
		 remTask node;
		 Emark := Ready)
   |evalstep (node as ref(app((ref rator,ref rand),Emark,WQ))) =
     let
      val old = copy node
     in
      (step node;
       if ((equal old node) orelse
           (!Emark = Ready) orelse
           (not (is_app (!node)))) (* Evaluation beendet ? *)
        then (wakeup WQ;           (* Wartende Prozesse reaktivieren *)
              remTask node;        (* Prozess entfernen *)
              Emark := Ready)      (* Knoten ist vollst"ndig evaluiert *)
        else ())                   (* der Scheduler kann die Evaluation 
                                      fortsetzen *)
     end;
val Seed = ref 4.34793435219781;
val Steps = ref 0;
fun Scheduler () =
 let
  fun rnd () =
   let
    val x = (! Seed)* 1475.37697;
    val res = x-real(floor x);
   in
    (Seed := res; res)
   end;
  fun intrand n = floor(rnd()*(real n));
 in
  if length(!Tasks) = 0 then ()
  else 
     (evalstep (nth(!Tasks,intrand (length (!Tasks))));
      Steps := 1+(!Steps);
      Scheduler())
 end;
fun eval node =
 (Steps := 0; Taskcounter := 0;
  Tasks := [];
  newTask node;
  Scheduler() handle _ => ();
  (show(dealloc node),!Steps,!Taskcounter));
fun run str = eval(alloc(c(read str)));
fun s () =
 let
  fun rnd () =
   let
    val x = (! Seed)* 1475.37697;
    val res = x-real(floor x);
   in
    (Seed := res; res)
   end;
  fun intrand n = floor(rnd()*(real n));
 in
  if length(!Tasks) = 0 then ""
  else 
     (evalstep (nth(!Tasks,intrand (length (!Tasks))));
      show(dealloc (last (!Tasks))))
 end;
fun rs str=
  (Tasks := [];
   newTask(alloc(ropt(c(read str))));
   s());