module Cont where

import MyState
import MyStream

newtype K r a = K ((a -> r) -> r)

unK :: K r a -> (a -> r) -> r
unK (K c) = c

instance Monad (K r) where
  return a    = K (\ c -> c a)
  (K m) >>= k = K (\ c -> m (\ a -> unK (k a) c))

{-
abort :: r -> K r a
abort v = K (\ c -> v)

callcc :: ((a -> K r b) -> K r a) -> K r a
callcc h = K (\ c -> let k a = K (\ d -> c a) in unK (h k) c)

callcc2 :: ((a -> r) -> K r a) -> K r a
callcc2 h = K (\ c -> unK (h c) c)
-}

-- type K0 r a  = (a -> r) -> r
type ST0 s a = s -> (a,s) 

newtype KST v s a = KST ((a -> WithIO s -> (v,WithIO s))
                            -> WithIO s -> (v,WithIO s))

unKST :: KST v s a -> (a -> WithIO s -> (v,WithIO s)) 
                   -> WithIO s -> (v,WithIO s)
unKST (KST m) = m


unitST a = \ s -> (a,s)

instance Monad (KST v s) where
  return a      = KST (\ c -> c a)
  (KST m) >>= k = KST (\ c -> m (\ a -> unKST (k a) c))

instance MyState (KST v) where
  get p    = KST (\ c (s,i,o) -> c (fst (p s)) (s,i,o))
  set p v  = KST (\ c (s,i,o) -> c () (snd (p s) v,i,o))

instance MyStream (KST v s) where
  readChar   = KST (\ c (s,ch:i,o) -> c ch (s,i,o))
  eof        = KST (\ c (s,i,o) -> c (null i) (s,i,o))
  writeStr v = KST (\ c (s,i,o) -> c () (s,i,o++v))

abort :: (WithIO s -> (v,WithIO s)) -> KST v s a
abort v = KST (\ c -> v)

callcc :: ((a -> KST v s b) -> KST v s a) -> KST v s a
callcc h = KST (\ c -> let k a = KST (\ d -> c a) in unKST (h k) c)

callcc2 :: ((a -> ST0 (WithIO s) v) -> KST v s a) -> KST v s a
callcc2 h = KST (\ c -> unKST (h c) c)

throw :: (a -> ST0 (WithIO s) v) -> a -> KST v s b
throw c a = KST (\ _ -> c a)

{-
foo = \ y -> begin
  set xP 1; set yP y;
  while get yP > 0 do begin
    val x = get xP in val y = get yP in
    if y==10 then break
    else if y==3 then begin
      set yP (y-1); continue
    end else ();
    set xP (x*y);
    set yP (y-1)
  end;
  get xP
end
-}

foo :: Integer -> KST a (Integer,Integer) Integer
foo  = \ n ->
         set xP 1 >>= \ _ ->
         set yP n >>= \ _ ->
         KST (\ _break ->
           let KST _while
                 = get yP >>= \ _x ->
                   if _x > 0 then
                     get xP >>= \ r ->
                     get yP >>= \ n ->
                     (if n == 10 then abort (_break ()) else
                        if n == 3 then
                          set yP (n - 1) >>= \ _ -> 
                          abort (_while _break)
                        else return ()) >>= \ _ ->
                     set xP (r * n) >>= \ _ -> 
                     set yP (n - 1) >>= \ _ -> 
                     KST _while
                   else return ()
             in _while _break) >>= \ _ -> 
         get xP

{-
bar = \ _ -> begin
    set xP 1;
  label1:
    if get xP > 100 then goto label2 else ();
    set xP (get xP * 2);
    goto label1;
  label2:
    get xP
  end
-}
bar :: t -> KST a (Integer, y) Integer
bar = \ _ ->
       set xP 1     >>= \ _ -> 
       KST (\ _end ->
          let label1 = \ _ -> unKST 
                         (get xP                             >>= \ _x -> 
                          (if _x > 100 then abort (label2 ()) 
                                       else return ())         >>= \ _ -> 
                          get xP                             >>= \ _x -> 
                          set xP (_x * 2)                    >>= \ _ -> 
                          abort (label1 ())) label2
              label2 = \ _ -> unKST (get xP) _end
            in label1 ())

{-
baz = \ x ->
  callcc (\ k ->
    100 + (if x==0 then 1 else k x))
-}

baz
  = \ x ->
      callcc
        (\ k ->
           (if x == 0 then return 1 else k x) >>= \ _x -> return (100 + _x))

{-
multlist = \ list ->
  let aux = \ xs -> \ k -> begin
        set xP 1; set yP xs;
        while not (null (get yP)) do begin
          val y = get yP in val n = head y in
          if n == 0 then k 0 else
            begin set xP (get xP*n); set yP (tail y);
                  writeStr " ";
                  write n
            end
        end;
        get xP
    end in
  val result = callcc (\ k -> aux list k) in begin
    writeStr ";\n result = ";
    write result
  end
-}


multlist = \ list ->
      let aux = \ xs ->
            return (\ k ->
               set xP 1              >>= \ _ ->
               set yP xs             >>= \ _ ->
               KST (\ _break ->
                  let KST _while
                        = get yP >>= \ _x ->
                          if not (null _x) then
                               get yP                 >>= \ y ->
                               (if head y == 0 then k 0 else
                                   get xP               >>= \ _x ->
                                   set xP (_x * head y) >>= \ _ ->
                                   set yP (tail y)      >>= \ _ ->
                                   writeStr " "             >>= \ _ -> 
                                   write (head y))      >>= \ _ -> 
                               KST _while
                             else return ()
                    in _while _break) >>= \ _ -> 
                get xP)
        in callcc (\ k -> aux list >>= \ _f -> 
                           _f k)   >>= \ result -> 
           writeStr "; result="        >>= \ _ -> 
           write result
{-
-- Util
increase = \ n -> \ k ->
     if n > 10 then ()
     else begin writeStr " i:"; write n;
     increase (n+1) (callcc k) end;
decrease = \ n -> \ k ->
     if n < 0 then ()
     else begin writeStr " d:"; write n; 
     decrease (n-1) (callcc k) end
coroutine = \ _ -> increase 0 (decrease 10)

-- The Util code above translates into the following code,
-- which is untypeable due to the need of an infinite type. 

increase n = return (\ k ->
               if n > 10 then return () else
                 writeStr " i:"   >>= \ _ ->
                 write n          >>= \ _ -> 
                 increase (n + 1) >>= \ _f -> 
                 callcc k         >>= \ _x -> 
                 _f _x)

decrease n = return (\ k ->
               if n < 0 then return () else
                 writeStr " d:"   >>= \ _ ->
                 write n          >>= \ _ -> 
                 decrease (n - 1) >>= \ f -> 
                 callcc k         >>= \ x -> 
                 f x)

-- which is hand-optimized to the following

increase n k = if n > 10 then return () else
                 writeStr " i:"   >>= \ _ ->
                 write n          >>= \ _ -> 
                 callcc k         >>= \ x -> 
                 increase (n + 1) x
decrease n k = if n < 0 then return () else
                 writeStr " d:"   >>= \ _ ->
                 write n          >>= \ _ -> 
                 callcc k         >>= \ x -> 
                 decrease (n - 1) x);

coroutine = increase 0 (decrease 10)

-- Here is a possible trick.
-}

data Trick v s = Trick { unTrick :: Trick v s -> KST v s (Trick v s)}

increase :: Integer -> Trick v s -> KST v s (Trick v s)
increase n k = if n > 10 then return k -- instead of (), to fit the type
                 else
                   writeStr " i:"                      >>= \ _ ->
                   write n                             >>= \ _ -> 
                   callcc (\ c -> unTrick k (Trick c)) >>= \ x -> 
                   increase (n + 1) x

decrease :: Integer -> Trick v s -> KST v s (Trick v s)
decrease n k = if n < 0 then return k  -- instead of (), to fit the type
                 else
                   writeStr " d:"                      >>= \ _ ->
                   write n                             >>= \ _ ->         
                   callcc (\ c -> unTrick k (Trick c)) >>= \ x -> 
                   decrease (n - 1) x

coroutine =  increase 0 (Trick (decrease 10))
-- e.g.) snd $ unKST coroutine (\ _ s -> ((),s)) ((),"","")

{-
-- which is translated back into Util

increase = \ n -> \ k ->
     if n > 10 then k
     else begin writeStr " i:"; write n;
     increase (n+1) (callcc (\ c -> unTrick k (Trick c))) end;
decrease = \ n -> \ k ->
     if n < 0 then k
     else begin writeStr " d:"; write n; 
     decrease (n-1) (callcc (\ c -> unTrick k (Trick c))) end
coroutine = \ _ -> increase 0 (Trick (decrease 10))

-}

{-
-- version for callcc2 and throw 
-- Util
increase2 = \ n -> \ k ->
     if n > 10 then ()
     else begin writeStr " i:"; write n;
     increase2 (n+1) (callcc2 (\ c -> throw k c)) end;

decrease2 = \ n -> \ k ->
     if n < 0 then ()
     else begin writeStr " d:"; write n; 
     decrease2 (n-1) (callcc2 (\ c -> throw k c)) end;

coroutine2 = \ _ -> callcc2 (\ u -> decrease2 10 (callcc2 (\ k -> throw u (increase2 0 k))))

-- The Util code above translates into the following code,
-- which is untypeable due to the need of an infinite type. 
increase2
  = \ n -> return (\ k ->
       if n > 10 then return () else
          writeStr " i:"             >>= \ _ ->
          write n                    >>= \ _ ->
          increase2 (n + 1)          >>= \ _f -> 
          callcc2 (\ c -> throw k c) >>= \ _x ->
           _f _x)
decrease2
  = \ n -> return (\ k ->
       if n < 0 then return () else
          writeStr " d:"             >>= \ _ -> 
          write n                    >>= \ _ ->
          decrease2 (n - 1)          >>= \ _f -> 
          callcc2 (\ c -> throw k c) >>= \ _x -> 
          _f _x)

coroutine2 = \ _ -> callcc2 (\ u ->
                      decrease2 10                 >>= \ f ->
                      callcc2 (\ k -> increase2 0     >>= \ g -> 
                                      g k             >>= \ y -> 
                                      throw u y)   >>= \ x -> 
                      f x)

-- which is hand-optimized to

increase2 n k = if n > 10 then return () else
                 writeStr " i:"             >>= \ _ ->
                 write n                    >>= \ _ ->
                 callcc2 (\ c -> throw k c) >>= \ x -> 
                 increase2 (n + 1) x

decrease2 n k = if n < 0 then return () else
                 writeStr " d:"             >>= \ _ ->
                 write n                    >>= \ _ ->
                 callcc2 (\ c -> throw k c) >>= \ x ->
                 decrease2 (n - 1) x

coroutine2 = callcc2 (\ c -> callcc2 (\ d -> increase2 0 d >>= \ y ->
                                            throw c y) >>= \ x ->
                            decrease2 10 x)
-- Here is a possible trick.
-}

newtype Mu r = Mu { unMu :: Mu r -> r }

-- Mu   :: (Mu r -> r) -> Mu r
-- unMu :: Mu r -> (Mu r -> r)

y f = (\ x -> f (unMu x x)) (Mu (\ x -> f (unMu x x)))

increase2 :: Integer -> Mu (ST0 (WithIO s) v) 
                     -> KST v s (Mu (ST0 (WithIO s) v))
increase2 n k = if n > 10 then return k -- instead of (), to fit the type
                  else
                    writeStr " i:"               >>= \ _ ->
                    write n                      >>= \ _ ->
                    callcc2 (\ c -> throw (unMu k) (Mu c)) >>= \ x -> 
                    increase2 (n + 1) x

decrease2 :: Integer -> Mu (ST0 (WithIO s) v) 
                     -> KST v s (Mu (ST0 (WithIO s) v))
decrease2 n k = if n < 0 then return k -- instead of (), to fit the type
                  else
                    writeStr " d:"               >>= \ _ ->
                    write n                      >>= \ _ ->
                    callcc2 (\ c -> throw (unMu k) (Mu c)) >>= \ x ->
                    decrease2 (n - 1) x

coroutine2 = callcc2 (\ c -> increase2 0 (Mu c)) >>= \ d ->
             decrease2 10 d

-- e.g.)  snd $ unKST coroutine2 (\ _ s -> ((),s)) ((),"","")