module Cont where

import ST

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

unitK :: a -> K r a
unitK a = \ c -> c a

bindK :: K r a -> (a -> K r b) -> K r b
m `bindK` k = \ c -> m (\ a -> k a c)

idK = unitST

abortK :: r -> K r a
abortK v = \ c -> v

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

type KST s v a = K (ST s v) a

failK :: e -> KST s e a
failK e = abortK (unitST e)

setXK ::  x -> KST (x, y, z) a ()
setXK v = \ c (x, y, z) -> c () (v, y, z)

setYK ::  y -> KST (x, y, z) a ()
setYK v = \ c (x, y, z) -> c () (x, v, z)

setZK ::  z -> KST (x, y, z) a ()
setZK v = \ c (x, y, z) -> c () (x, y, v)

getXK :: () -> KST (x, y, z) a x
getXK ()  = \ c (x, y, z) -> c x (x, y, z)

getYK :: () -> KST (x, y, z) a y
getYK ()  = \ c (x, y, z) -> c y (x, y, z)

getZK :: () -> KST (x, y, z) a z
getZK ()  = \ c (x, y, z) -> c z (x, y, z)

foo :: Integer -> KST (Integer, Integer, z) a Integer
foo = \ y ->
        setXK 1  	       `bindK` \ _ -> 
        setYK y  	       `bindK` \ _ -> 
        (\ _break ->
          let _while
                = getYK ()        `bindK` \ y ->
                  if y > 0 then
                       getXK ()             `bindK` \ x ->
                       getYK ()             `bindK` \ y ->
                       (if y == 10 then abortK (_break ()) else
                          if y == 3 then
                              setYK (y - 1)     `bindK` \ _ ->
                              abortK (_while _break)
                            else unitK ()) `bindK` \ _ ->
                       setXK (x * y) 	   `bindK` \ _ ->
                       setYK (y - 1) 	   `bindK` \ _ ->
                       _while
                    else unitK ()
            in _while _break)  `bindK` \ _ ->
        getXK ()

bar :: t -> KST (Integer, y, z) a Integer
bar = \ _ ->
       setXK 1     `bindK` \ _ -> 
        \ _end ->
          let label1 = \ _ ->
                         (getXK ()                             `bindK` \ _x -> 
                          (if _x > 100 then abortK (label2 ()) 
                                       else unitK ())          `bindK` \ _ -> 
                          getXK ()                             `bindK` \ _x -> 
                          setXK (_x * 2)                       `bindK` \ _ -> 
                          abortK (label1 ())) label2
              label2 = \ _ -> getXK () _end
            in label1 ()

baz = \ list ->
  let mult = \ xs ->
                unitK
                  (\ k ->
                     setXK 1                `bindK` \ _ -> 
                     setYK xs               `bindK` \ _ -> 
                     setZK ""               `bindK` \ _ -> 
                     (\ _break ->
                        let _while
                              = getYK ()                                  `bindK` \ y -> 
                                if not (null y) then
                                    getYK ()                                  `bindK` \ y -> 
                                    (if head y == 0 then k 0 else
                                       getXK ()                               `bindK` \ x -> 
                                       setXK (x * head y)                     `bindK` \ _ -> 
                                       setYK (tail y)                         `bindK` \ _ -> 
                                       getZK ()                               `bindK` \ z ->  
                                       setZK (z ++ " " ++ show (head y))) `bindK` \ _ -> 
                                    _while
                                  else unitK ()
                          in _while _break) `bindK` \ _ -> 
                     getXK ())
        in callccK
             (\ k ->
                mult list `bindK` \ _f -> 
                _f k)                  `bindK` \ result -> 
           getZK ()                    `bindK` \ z -> 
           unitK ("result = " ++ show result ++ "; z = \"" ++ z ++"\";")