head	1.3;
access;
symbols;
locks
	strick:1.3; strict;
comment	@# @;


1.3
date	2009.04.26.11.04.54;	author strick;	state Exp;
branches;
next	1.2;

1.2
date	2009.04.26.11.01.05;	author strick;	state Exp;
branches;
next	1.1;

1.1
date	2009.04.26.10.31.41;	author strick;	state Exp;
branches;
next	;


desc
@@


1.3
log
@/dev/null
@
text
@infixl 1 `chain`

main = do
  print "plus3 10 ->"
  print $ plus3 10
  print "squareRoot 81 ->"
  print $ squareRoot 81
  print "runPutAndGet \"key\" 888"
  print $ runPutAndGet "key" 888
  print "runHypotenuse 3 4"
  print $ runHypotenuse 3 4
  print "250 OKAY."

--------------------------------------------
plus3 :: Int -> Int
plus3 x = run incrThrice x
  where
    incrThrice =
      incr `chain` \_ -> 
      incr `chain` \_ -> 
      incr `chain` \_ -> 
      get

    incr =
      get `chain` \i ->
      put (1 + i) `chain` \_ ->
      inject i

-------------------------------------------

runPutAndGet k v = run (putAndGet k v) emptyEnv

putAndGet k v =
  putEnv k v `chain` \_ ->
  getEnv k `chain` \z ->
  inject z

-------------------------------------------

runHypotenuse x y = run (hypotenuse' x y) emptyEnv 
  where
    hypotenuse' x y =
      setXandY'' x y `chain` \_ ->
      hypotenuse''

    setXandY'' x y =
      putEnv "X" x `chain` \_ ->
      putEnv "Y" y

    hypotenuse'' =
      getEnv "X" `chain` \x ->
      getEnv "Y" `chain` \y ->
      inject $ squareRoot (x*x + y*y)


squareRoot x = findIndex squares x
  where 
    squares = [x*x | x <- [1..]]

    findIndex [] item = 0
    findIndex (x:xs) item | x == item  =  1
    findIndex (x:xs) item              =  1 + (findIndex xs item)

-------------------------------------------
-- Instead of class Monad, I call it class Bird.
-- Instead of return & (>>=), I call them inject & chain.

class Bird m where
  inject :: a -> m a
  chain :: m a -> (a -> m b) -> m b

-------------------------------------------
-- My own Steak Bird (compare with State Monad (TM)).

newtype Steak s a = STEAK (s -> (s, a))

instance Bird (Steak s) where
  
  inject x = STEAK $ \steak -> (steak, x)

  chain (STEAK p) q = STEAK $ \steak0 ->
      let (steak1, x1) = p steak0
          (STEAK f2) = q x1
      in f2 steak1

get :: Steak s s
get = STEAK $ \s -> (s, s)

put :: s -> Steak s ()
put s = STEAK $ \_ -> (s, ())

run :: Steak s a -> s -> a
run (STEAK f) steak  =
    let (steak2, x) = f steak
    in x

run' :: Steak s a -> s -> (s, a)
run' (STEAK f) steak  = f steak
-------------------------------------------

type Env  = [(String, Int)]

getEnv :: String -> Steak Env Int
getEnv key = STEAK $ \s -> (s, lookup key s)
  where
    lookup :: String -> Env -> Int
    lookup k [] = 0
    lookup k ((k',v'):kvs) | k == k'  = v'
    lookup k ((k',v'):kvs)            = lookup k kvs

putEnv :: String -> Int -> Steak Env ()
putEnv k v = STEAK $ \s -> ((k, v):s, ())

putEnv2 :: String -> Int -> String -> Int -> Steak Env ()
putEnv2 k1 v1 k2 v2 =
    putEnv k1 v1 `chain` \_ ->
    putEnv k2 v2

emptyEnv :: Env
emptyEnv = []

@


1.2
log
@/dev/null
@
text
@d6 3
a8 1
  print $ squareRoot 25
d10 3
a12 1
  print $ hypotenuse 3 4
d40 1
a40 1
hypotenuse x y = run (hypotenuse' x y) emptyEnv 
@


1.1
log
@/dev/null
@
text
@d6 3
d13 13
d27 6
a32 10
incrThrice =
  incr `chain` \_ -> 
  incr `chain` \_ -> 
  incr `chain` \_ -> 
  get

incr =
  get `chain` \i ->
  put (1 + i) `chain` \_ ->
  inject i
d36 24
d103 3
a105 1
    lookup k e = 0
d115 2
a116 2
emptySteak :: Env
emptySteak = []
@