[project @ 1999-11-02 15:19:55 by simonpj]
authorsimonpj <unknown>
Tue, 2 Nov 1999 15:19:57 +0000 (15:19 +0000)
committersimonpj <unknown>
Tue, 2 Nov 1999 15:19:57 +0000 (15:19 +0000)
Add several new program, enable others

12 files changed:
spectral/Makefile
spectral/constraints/Main.hs [new file with mode: 0644]
spectral/constraints/Makefile [new file with mode: 0644]
spectral/constraints/constraints.stdout [new file with mode: 0644]
spectral/cryptarithm1/Main.hs [new file with mode: 0644]
spectral/cryptarithm1/Makefile [new file with mode: 0644]
spectral/cryptarithm1/cryptarithm1.stdout [new file with mode: 0644]
spectral/cryptarithm2/Main.hs [new file with mode: 0644]
spectral/cryptarithm2/Makefile [new file with mode: 0644]
spectral/cryptarithm2/MonadState.lhs [new file with mode: 0644]
spectral/cryptarithm2/MonadTrans.hs [new file with mode: 0644]
spectral/cryptarithm2/cryptarithm2.stdout [new file with mode: 0644]

index 75dd95e..e0ac2c1 100644 (file)
@@ -1,10 +1,18 @@
 TOP = ..
 include $(TOP)/mk/boilerplate.mk
 
+# SLPJ subset
+# SUBDIRS = \
+#  expert gcd hartel knights mandel mandel2 \
+#  minimax multiplier simple 
+
 SUBDIRS = \
   ansi awards banner boyer boyer2 calendar cichelli circsim clausify cse \
   eliza expert fibheaps fish fft2 gcd hartel life knights mandel mandel2 \
-  minimax multiplier pretty primetest rewrite scc simple sorting treejoin
+  minimax multiplier pretty primetest rewrite scc simple sorting treejoin power \
+  constraints cryptarithm1 cryptarithm2 para puzzle salishan sphere 
+
+# compreals    no suitable test data
 
 include $(TOP)/mk/target.mk
 
diff --git a/spectral/constraints/Main.hs b/spectral/constraints/Main.hs
new file mode 100644 (file)
index 0000000..2f2af2e
--- /dev/null
@@ -0,0 +1,267 @@
+{- Andrew Tolmach and Thomas Nordin's contraint solver
+
+       See Proceedings of WAAAPL '99
+-}
+
+import Prelude hiding (Maybe(Just,Nothing))
+import List
+
+-----------------------------
+-- The main program
+-----------------------------
+
+main =  sequence_ (map try [bt, bm, bjbt, bjbt', fc])
+     where
+       try algorithm = print (length (search algorithm (queens 10)))
+
+-----------------------------
+-- Figure 1. CSPs in Haskell.
+-----------------------------
+
+type Var = Int
+type Value = Int
+
+data Assign = Var := Value deriving (Eq, Ord, Show)
+
+type Relation = Assign -> Assign -> Bool
+
+data CSP = CSP { vars, vals :: Int, rel :: Relation } 
+
+type State = [Assign]
+
+level :: Assign -> Var
+level (var := val) = var
+
+value :: Assign -> Value
+value (var := val) = val
+
+maxLevel :: State -> Var
+maxLevel [] = 0
+maxLevel ((var := val):_) = var
+
+complete :: CSP -> State -> Bool
+complete CSP{vars=vars} s = maxLevel s == vars
+
+generate :: CSP -> [State]
+generate CSP{vals=vals,vars=vars} = g vars
+  where g 0 = [[]]
+        g var = [ (var := val):st | val <- [1..vals], st <- g (var-1) ]
+
+inconsistencies :: CSP -> State -> [(Var,Var)]
+inconsistencies CSP{rel=rel} as =  [ (level a, level b) | a <- as, b <- reverse as, a > b, not (rel a b) ]
+
+consistent :: CSP -> State -> Bool
+consistent csp = null . (inconsistencies csp)
+
+test :: CSP -> [State] -> [State]
+test csp = filter (consistent csp)
+
+solver :: CSP -> [State]
+solver csp  = test csp candidates
+  where candidates = generate csp
+
+queens :: Int -> CSP
+queens n = CSP {vars = n, vals = n, rel = safe}
+  where safe (i := m) (j := n) = (m /= n) && abs (i - j) /= abs (m - n)
+
+-------------------------------
+-- Figure 2.  Trees in Haskell.
+-------------------------------
+
+data Tree a = Node a [Tree a]
+
+label :: Tree a -> a
+label (Node lab _) = lab
+
+type Transform a b = Tree a -> Tree b
+
+mapTree  :: (a -> b) -> Transform a b
+mapTree f (Node a cs) = Node (f a) (map (mapTree f) cs)
+
+foldTree :: (a -> [b] -> b) -> Tree a -> b
+foldTree f (Node a cs) = f a (map (foldTree f) cs)
+
+filterTree :: (a -> Bool) -> Transform a a
+filterTree p = foldTree f
+  where f a cs = Node a (filter (p . label) cs)
+
+prune :: (a -> Bool) -> Transform a a
+prune p = filterTree (not . p)
+
+leaves :: Tree a -> [a]
+leaves (Node leaf []) = [leaf]
+leaves (Node _ cs) = concat (map leaves cs)
+
+initTree :: (a -> [a]) -> a -> Tree a
+initTree f a = Node a (map (initTree f) (f a))
+
+--------------------------------------------------
+-- Figure 3.  Simple backtracking solver for CSPs.
+--------------------------------------------------
+
+mkTree :: CSP -> Tree State
+mkTree CSP{vars=vars,vals=vals} = initTree next []
+  where next ss = [ ((maxLevel ss + 1) := j):ss | maxLevel ss < vars, j <- [1..vals] ]
+
+data Maybe a = Just a | Nothing deriving Eq
+
+earliestInconsistency :: CSP -> State -> Maybe (Var,Var)
+earliestInconsistency CSP{rel=rel} [] = Nothing
+earliestInconsistency CSP{rel=rel} (a:as) = 
+        case filter (not . rel a) (reverse as) of
+          [] -> Nothing
+          (b:_) -> Just (level a, level b)
+
+labelInconsistencies :: CSP -> Transform State (State,Maybe (Var,Var))
+labelInconsistencies csp = mapTree f 
+    where f s = (s,earliestInconsistency csp s)
+
+btsolver0 :: CSP -> [State]
+btsolver0 csp =
+  (filter (complete csp) . leaves . (mapTree fst) . prune ((/= Nothing) . snd) 
+                                            . (labelInconsistencies csp) .  mkTree) csp
+
+-----------------------------------------------
+-- Figure 6. Conflict-directed solving of CSPs.
+-----------------------------------------------
+
+data ConflictSet = Known [Var] | Unknown deriving Eq
+
+knownConflict :: ConflictSet -> Bool
+knownConflict (Known (a:as)) = True
+knownConflict _              = False
+
+knownSolution :: ConflictSet -> Bool
+knownSolution (Known []) = True
+knownSolution _          = False
+
+checkComplete :: CSP -> State -> ConflictSet
+checkComplete csp s = if complete csp s then Known [] else Unknown
+
+type Labeler = CSP -> Transform State (State, ConflictSet)
+
+search :: Labeler -> CSP -> [State]
+search labeler csp =
+  (map fst . filter (knownSolution . snd) . leaves . prune (knownConflict . snd) . labeler csp . mkTree) csp
+
+bt :: Labeler
+bt csp = mapTree f
+      where f s = (s, 
+                   case earliestInconsistency csp s of
+                     Nothing    -> checkComplete csp s
+                     Just (a,b) -> Known [a,b])
+
+btsolver :: CSP -> [State]
+btsolver = search bt
+
+-------------------------------------
+-- Figure 7. Randomization heuristic.
+-------------------------------------
+
+hrandom :: Int -> Transform a a
+hrandom seed (Node a cs) = Node a (randomList seed' (zipWith hrandom (randoms seed') cs))
+  where seed' = random seed
+
+btr :: Int -> Labeler
+btr seed csp = bt csp . hrandom seed
+
+---------------------------------------------
+-- Support for random numbers (not in paper).
+---------------------------------------------
+
+random2 :: Int -> Int
+random2 n = if test > 0 then test else test + 2147483647
+  where test = 16807 * lo - 2836 * hi
+        hi   = n `div` 127773
+        lo   = n `rem` 127773
+
+randoms :: Int -> [Int]
+randoms = iterate random2
+
+random :: Int -> Int
+random n = (a * n + c) -- mod m
+  where a = 994108973
+        c = a
+
+randomList :: Int -> [a] -> [a]
+randomList i as = map snd (sortBy (\(a,b) (c,d) -> compare a c) (zip (randoms i) as))
+
+-------------------------
+-- Figure 8. Backmarking.
+-------------------------
+
+type Table = [Row]       -- indexed by Var
+type Row = [ConflictSet] -- indexed by Value
+
+bm :: Labeler
+bm csp = mapTree fst . lookupCache csp . cacheChecks csp (emptyTable csp)
+
+emptyTable :: CSP -> Table
+emptyTable CSP{vars=vars,vals=vals} = []:[[Unknown | m <- [1..vals]] | n <- [1..vars]]
+
+cacheChecks :: CSP -> Table -> Transform State (State, Table)
+cacheChecks csp tbl (Node s cs) =
+  Node (s, tbl) (map (cacheChecks csp (fillTable s csp (tail tbl))) cs)
+
+fillTable :: State -> CSP -> Table -> Table
+fillTable [] csp tbl = tbl
+fillTable ((var' := val'):as) CSP{vars=vars,vals=vals,rel=rel} tbl =
+    zipWith (zipWith f) tbl [[(var,val) | val <- [1..vals]] | var <- [var'+1..vars]]
+          where f cs (var,val) = if cs == Unknown && not (rel (var' := val') (var := val)) then 
+                                   Known [var',var] 
+                                 else cs
+
+lookupCache :: CSP -> Transform (State, Table) ((State, ConflictSet), Table)
+lookupCache csp t = mapTree f t
+  where f ([], tbl)      = (([], Unknown), tbl)
+        f (s@(a:_), tbl) = ((s, cs), tbl) 
+            where cs = if tableEntry == Unknown then checkComplete csp s else tableEntry
+                   tableEntry = (head tbl)!!(value a-1)
+
+--------------------------------------------
+-- Figure 10. Conflict-directed backjumping.
+--------------------------------------------
+
+bjbt :: Labeler
+bjbt csp = bj csp . bt csp
+
+bjbt' :: Labeler
+bjbt' csp = bj' csp . bt csp
+
+bj :: CSP -> Transform (State, ConflictSet) (State, ConflictSet)
+bj csp = foldTree f 
+  where f (a, Known cs) chs = Node (a,Known cs) chs
+        f (a, Unknown)  chs = Node (a,Known cs') chs
+          where cs' = combine (map label chs) []
+
+combine :: [(State, ConflictSet)] -> [Var] -> [Var]
+combine []                 acc = acc 
+combine ((s, Known cs):css) acc =
+  if maxLevel s `notElem` cs then cs else combine css (cs `union` acc)
+
+bj' :: CSP -> Transform (State, ConflictSet) (State, ConflictSet)
+bj' csp = foldTree f 
+  where f (a, Known cs) chs = Node (a,Known cs) chs
+        f (a, Unknown) chs = if knownConflict cs' then Node (a,cs') [] else Node (a,cs') chs
+           where cs' = Known (combine (map label chs) [])
+
+-------------------------------
+-- Figure 11. Forward checking.
+-------------------------------
+
+fc :: Labeler
+fc csp = domainWipeOut csp . lookupCache csp . cacheChecks csp (emptyTable csp)
+
+collect :: [ConflictSet] -> [Var]
+collect [] = []
+collect (Known cs:css) = cs `union` (collect css)
+
+domainWipeOut :: CSP -> Transform ((State, ConflictSet), Table) (State, ConflictSet)
+domainWipeOut CSP{vars=vars} t = mapTree f t
+  where f ((as, cs), tbl) = (as, cs')  
+          where wipedDomains = ([vs | vs <- tbl, all (knownConflict) vs]) 
+                cs' = if null wipedDomains then cs else Known (collect (head wipedDomains))
+
+
+
+
diff --git a/spectral/constraints/Makefile b/spectral/constraints/Makefile
new file mode 100644 (file)
index 0000000..53e5abe
--- /dev/null
@@ -0,0 +1,6 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+
+include $(TOP)/mk/target.mk
+
diff --git a/spectral/constraints/constraints.stdout b/spectral/constraints/constraints.stdout
new file mode 100644 (file)
index 0000000..aa1e611
--- /dev/null
@@ -0,0 +1,5 @@
+724
+724
+724
+724
+724
diff --git a/spectral/cryptarithm1/Main.hs b/spectral/cryptarithm1/Main.hs
new file mode 100644 (file)
index 0000000..47a53ed
--- /dev/null
@@ -0,0 +1,164 @@
+{- From Sergey Mechveliani, Oct 99
+
+This pretends to be the "fair" improved Cryptarithm solver  test for
+the performance comparison between  Haskell  and  C++.
+
+--------------------------------------------------------------------
+Compilation:   g++       -O3                       t.cc
+               ghc-4.04  -c -fvia-C -O2 -O2-for-C  t.hs
+
+RESULTS:    Platform1 -   C++  is  15 times faster,
+            Platform2 -            10 times faster,
+
+   Platform1:   PC i-586,  Linux Debian
+           g++  version:
+           g++ -v  says
+            `gcc version egcs-2.90.29 980515 (egcs-1.0.3 release)'
+
+   Platform2:  some machine with larger Cache.
+
+
+I thank  Fergus Henderson <fjh@cs.mu.oz.au>
+
+for the improvements in the C++ program and for suggesting to use the
+list comprehensions in `permutations' (this saved another 10-15% of
+cost).
+
+The test shows the performance ratio  
+                       CC++ / Haskell (ghc-4.04)   between 10 and 15
+
+- it varies depending on the platform and other features.
+
+It would be interesting to observe your running results, remarks,
+comparison to other systems.
+
+What is the meaning of such test? 
+Comparing what is better an orange or an apple?
+
+To my mind, this reflects the performance cost of the benefits of 
+a higher level, functional language.
+And it is chosen an unlucky task example for Haskell.
+The nature of this task is so that it allows to generate 
+permutations "in place", by updating the C++ vector.
+I expect the smaller ratio for other, "average" tasks.
+
+And it is interesting, how the functional compiler of future might 
+optimize the below program. How essentially it could reduce the 
+cost ratio?
+
+--------------------------------------------------------------------
+The  Cryptarithm solver test was proposed to the Haskell e-mail list 
+
+by  Mark Engelberg <mark.engelberg@bigfoot.com>  
+on  17 September 1999.
+
+This is actually the test for the speed of the permutation 
+generator program.
+Mark Engelberg spoke of the task of finding first permutation
+satisfying certain equation.
+And he compared the Haskell program with the C++ program that uses
+the  next_permutation  library function.
+
+This comparison was incorrect, because it was not known whether the
+Haskell and C++ programs test the same number of permutations before
+finding the solution. For, it was not known in what order 
+next_permutation  generates the permutations.
+  ------------------------------------------------------------------
+  Below follow the programs for the improved test:
+
+  find  ALL  the permutations on  [0..9]  satisfying the condition
+  \[t,h,i,r,y,w,e,l,v,n] ->
+                      expand t h i r t y + 5 * expand t w e l v e ==
+                      expand n i n e t y
+      where
+      expand a b c d e f = f +e*10 +d*100 +c*1000 +b*10000 +a*100000
+  ------------------------------------------------------------------
+The real difference makes only this "ALL" part:
+all the permutations are tested - though only one satisfies the 
+condition.
+The differences to the original programs are as follows.
+
+* Both programs test each of 10! permutations.
+* The below Haskell program seems to generate the permutations 2-3 
+  times faster than the original program.
+* The C++ program uses the loop 
+                              do {...} while (next_permutation(...))
+  to list the solutions (it terminates when all the permutations
+  are listed).
+
+One amazing point: consider the last equation of `permutations':
+
+                           ...= (j:k:ks): [(k:aks) | aks <- addj ks]
+
+Replacing it with          ...  ...     : (map (k:) $ addj ks)
+slows it down in 20% in ghc-4.04.
+
+Fergus Henderson also tried Mercury, which showed somewhat higher
+performance, especially, whith "memory recover by backtracking".
+
+Fergus, could you show the test results? 
+I mean the final source program in Mercury, timings, platform,
+versions.
+
+------------------
+Sergey Mechveliani
+mechvel@botik.ru
+
+-}
+
+
+-- Haskell ---------------------------------------------------------
+
+main = putStr $ shows (filter condition $ permutations p0) "\n"
+         where
+         p0                              = [0..9] :: [Int]
+         condition [t,h,i,r,y,w,e,l,v,n] =
+                      expand t h i r t y + 5 * expand t w e l v e ==
+                      expand n i n e t y
+
+expand a b c d e f = f + e*10 + d*100 + c*1000 + b*10000 + a*100000
+                     :: Int
+
+permutations :: [Int] -> [[Int]]
+            -- build the full permutation list given an ordered list
+
+permutations []     = [[]]
+permutations (j:js) = [r | pjs <- permutations js, r <- addj pjs]
+                  where                   
+                  addj []     = [[j]]
+                  addj (k:ks) = (j:k:ks): [(k:aks) | aks <- addj ks]
+
+{-
+-- C++  ------------------------------------------------------------
+
+#include <vector>
+#include <algorithm>
+#include <iostream>
+
+using namespace std;
+
+inline long expand (long a, long b, long c, long d, long e, long f)
+{
+ return f+10*e+100*d+1000*c+10000*b+100000*a;
+}
+
+int main()
+{
+ long  t,h,i,r,y,w,e,l,v,n;
+
+ long temp[10] = {0,1,2,3,4,5,6,7,8,9};
+ vector<long> x(temp,temp+10);
+ do
+   {t = x[0];  h = x[1];  i = x[2];  r = x[3];  y = x[4];
+    w = x[5];  e = x[6];  l = x[7];  v = x[8];  n = x[9];
+
+    if (expand(n,i,n,e,t,y) ==
+                         expand(t,h,i,r,t,y) + 5*expand(t,w,e,l,v,e)
+       )
+     cout << t << h << i << r << y << w << e << l << v << n << '\n';
+   }
+   while ( next_permutation(x.begin(), x.end()) );
+ cout << "FINISHED\n";
+}
+
+-}
diff --git a/spectral/cryptarithm1/Makefile b/spectral/cryptarithm1/Makefile
new file mode 100644 (file)
index 0000000..b0ddca4
--- /dev/null
@@ -0,0 +1,5 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+include $(TOP)/mk/target.mk
+
diff --git a/spectral/cryptarithm1/cryptarithm1.stdout b/spectral/cryptarithm1/cryptarithm1.stdout
new file mode 100644 (file)
index 0000000..2e71c26
--- /dev/null
@@ -0,0 +1 @@
+[[1,9,4,2,5,3,0,7,6,8]]
diff --git a/spectral/cryptarithm2/Main.hs b/spectral/cryptarithm2/Main.hs
new file mode 100644 (file)
index 0000000..6f88c21
--- /dev/null
@@ -0,0 +1,127 @@
+{- Andy Gill, Oct 99 
+
+Here is a generic cryptarithm solver, written in Haskell. It does
+use a State Monad library, which is based on the work documented in 
+"Functional Programming with Overloading and Higher-Order Polymorphism",
+Mark P. Jones, Advanced School of Functional Programming, 1995.
+
+This can solve the puzzle in about 3 seconds on my laptop.
+On key optimization is captured by the line
+     guard (topN `mod` 10 == botN)
+in the function solve. It prunes searches than simply
+can not ever reach valid results.
+-}
+
+module Main where
+
+import Monad
+import MonadState
+import List
+import Maybe
+
+--    newtype DigitState = DigitState (Digits -> [(a,Digits))])
+-- which some might recognize as the list-of-successes parsing monad.
+
+type DigitState a = StateT Digits [] a
+
+-- Our digits state
+-- * First we have the remaining digit to allocate.
+-- * Second, we have the mapping from Char to Digit,
+--   for the chars that have been mapped so far.
+
+data Digits = Digits {
+               digits :: [Int],
+               digitEnv :: [(Char,Int)] 
+       } deriving Show
+
+initState = Digits {
+               digits = [0..9],
+               digitEnv = []
+               }
+
+-- permute adds a mapping from a char to each of the
+-- remaining allocable digits.
+-- This is used in the context of the list-of-successes
+-- monad, so it actually returns all possible mappings.
+
+permute :: Char -> DigitState Int
+permute c =
+     do st <- get
+       let xs = digits st
+       (i,is) <- lift [ (x,xs \\ [x]) | x <-  xs]
+       put (st { digits = is,
+                 digitEnv = (c,i):digitEnv st })
+       return i
+
+-- select attempt first checks to see if a mapping
+-- from a specific char to digit already has been
+-- mapped. If so, use the mapping, otherwise
+-- add a new mapping.
+
+select :: Char -> DigitState Int
+select c = 
+     do st <- get
+       case lookup c (digitEnv st) of
+         Just r -> return r
+         Nothing -> permute c
+
+-- solve takes a list of list of (backwards) letters,
+-- and a list of (backwards) letters, and tries
+-- to map the letter to digits, such that
+-- the sum of the first list of letters (mapped to digits)
+-- is equal to the sum of the second list of letters,
+-- again mapped to digits.
+--
+-- So a possible mapping for A+B=C might be
+-- solve ["A","B"] "C" 0
+--       => A -> 1, B -> 2, C -> 3
+
+solve :: [[Char]] -> [Char] -> Int -> DigitState ()
+solve tops (bot:bots) carry =
+  do topN <- (case tops of
+                  [] -> return carry
+                  (top:_) -> 
+                    do topNS <- mapM select top
+                       return (sum topNS + carry))
+     botN <- select bot
+     guard (topN `mod` 10 == botN)     -- key optimization
+     solve (rest tops) bots (topN `div` 10)
+  where
+     rest []     = []
+     rest (x:xs) = xs
+solve [] [] 0 = return ()
+solve _  _  _ = mzero
+
+-- Puzzle provides a cleaner interface into solve.
+-- The strings are in the order *we* write them.
+
+puzzle :: [[Char]] -> [Char] -> String
+puzzle top bot = 
+            if length (nub (concat top ++ bot)) > 10 
+            then error "can not map more than 10 chars"
+       else if topVal /= botVal 
+            then error ("Internal Error")
+       else unlines [ [c] ++ " => " ++ show i |
+                       (c,i) <- digitEnv answer
+                  ]
+   where
+       solution = solve (transpose (map reverse top)) 
+                        (reverse bot)
+                        0
+       answer  = case (execStateT solution initState) of
+                    (a:_) -> a
+                    [] -> error "can not find a solution"
+       env    = digitEnv answer
+       look c = fromJust (lookup c env)
+       topVal = sum [expand xs | xs <- top] 
+       botVal = expand bot
+       expand = foldl (\ a b -> a * 10 + look b) 0
+                       
+main = putStr (
+       puzzle  ["THIRTY",
+                "TWELVE",
+                "TWELVE",
+                "TWELVE",
+                "TWELVE",
+                "TWELVE"]
+                "NINETY")
diff --git a/spectral/cryptarithm2/Makefile b/spectral/cryptarithm2/Makefile
new file mode 100644 (file)
index 0000000..b9798ec
--- /dev/null
@@ -0,0 +1,7 @@
+TOP = ../..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_HC_OPTS += -fglasgow-exts
+
+include $(TOP)/mk/target.mk
+
diff --git a/spectral/cryptarithm2/MonadState.lhs b/spectral/cryptarithm2/MonadState.lhs
new file mode 100644 (file)
index 0000000..65b5998
--- /dev/null
@@ -0,0 +1,184 @@
+
+<h1>MonadState</h1>
+<haskell:module>
+  <Name>MonadState</>
+  <Version>0.1 alpha</>
+  <Copywrite>The contents of this module are
+       understood to be a straightforward implementation of
+       part of the fokelore of the functional programming community,
+       and therefore the contents are in the public domain.</>
+  <Author>
+       Rendered by <A HREF="http://www.cse.ogi.edu/~andy">Andy Gill</a>,
+       based on the paper
+       <em>Functional Programming with Overloading and
+           Higher-Order Polymorphism</em>, 
+         <A HREF="http://www.cse.ogi.edu/~mpj">Mark P Jones</a>,
+               Advanced School of Functional Programming, 1995.</>
+  <Restrictions>       
+       This requires multi parameter classes
+       and functional dependencies.
+       </>
+  <Tested>Hugs98</>
+</haskell:module>
+
+<hr/>
+
+> module MonadState (
+>      MonadState(..),
+>      modify,
+>      State,          -- abstract
+>      runState,
+>      mapState,
+>      evalState,
+>      execState,
+>      StateT,         -- abstract
+>      runStateT,
+>      mapStateT,
+>      evalStateT,
+>      execStateT,
+>      module MonadTrans
+>      ) where
+
+> import Monad
+> import MonadTrans
+
+<haskell:class>
+  <TName>MonadState</>
+</haskell:class>
+{-
+ - This class has two functions.
+ - get : returns the state from the internals of the monad,
+ - put : changes the state inside the monad.
+ -}
+
+> class (Monad m) => MonadState s m where
+>      get :: m s
+>      put :: s -> m ()
+
+
+<haskell:function>
+  <Purpose>Monadic state transformer.</>
+  <Description>
+      Maps an old state to a new state inside a state monad.
+      The old state is thrown away.</>
+  <Example>
+       <haskell:code bgcolor="#ff88ff">
+         Main> :t modify ((+1) :: Int -> Int)
+         modify (...) :: (MonadState Int a) => a ()
+       </haskell:code>
+       <p>This says that modify (+1) acts over any
+       Monad that is a member of the MonadState class,
+       with an <haskell:expr>Int</haskell:expr> state.</p>
+  </Example>
+</haskell:function>
+
+> modify :: (MonadState s m) => (s -> s) -> m ()
+> modify f = do s <- get
+>              put (f s)
+
+------------------------------------------------------------------------------
+{- Our parameterizable state monad
+ -}
+
+> newtype State s a = State { runState :: s -> (a,s) }
+
+{-
+ - The State Monad structure is paramterized over just the state:
+ -
+ -}
+
+> instance Functor (State s) where
+>      fmap f p = State (\ s ->
+>              let (x,s') = runState p s
+>              in  (f x,s'))
+
+> instance Monad (State s) where
+>    return v  = State (\ s -> (v,s))
+>    p  >>= f  = State (\ s -> let (r,s') = runState p s
+>                           in runState (f r) s')
+>    fail str  = State (\ s -> error str)
+
+> instance MonadState s (State s) where
+>      get   = State (\ s -> (s,s))
+>      put v = State (\ _ -> ((),v))
+
+
+> mapState :: ((a,s) -> (b,s)) -> State s a -> State s b
+> mapState f m = State (f . runState m)
+
+> evalState :: State s a -> s -> a
+> evalState m s = fst (runState m s)
+
+> execState :: State s a -> s -> s
+> execState m s = snd (runState m s)  
+
+------------------------------------------------------------------------------
+{- Our parameterizable state monad, with an inner monad
+ -}
+
+> newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+{-
+ - The StateT Monad structure is paramterized over two things:
+ -  s: The State itself.
+ -  m: The inner monad. 
+ -
+ - Here are some examples of use:
+ -
+ - (Parser from ParseLib with Hugs)
+ - type Parser a = StateT String [] a
+ -    ==> StateT (String -> [(a,String)])
+ - For example, item can be written as:
+ -     item = do (x:xs) <- get
+ -               put xs
+ -               return x
+ -
+ - type BoringState s a = StateT s Indentity a
+ -    ==> StateT (s -> Identity (a,s))
+ -
+ - type StateWithIO s a = StateT s IO a
+ -    ==> StateT (s -> IO (a,s))
+ -
+ - type StateWithErr s a = StateT s Maybe a
+ -    ==> StateT (s -> Maybe (a,s))
+ -}
+
+> instance (Monad m) => Functor (StateT s m) where
+>      -- fmap :: (a -> b) -> StateT s m a -> StateT s m b
+>      fmap f p = StateT (\ s ->
+>              do (x,s') <- runStateT p s
+>                 return (f x,s'))
+> 
+> instance (Monad m) => Monad (StateT s m) where
+>    return v  = StateT (\ s -> return (v,s))
+>    p  >>= f  = StateT (\ s -> do (r,s') <- runStateT p s
+>                                 runStateT (f r) s')
+>    fail str  = StateT (\ s -> fail str)
+> 
+> instance (MonadPlus m) => MonadPlus (StateT s m) where
+>      mzero       = StateT (\ s -> mzero)
+>      p `mplus` q = StateT (\ s -> runStateT p s `mplus` runStateT q s)
+> 
+> instance (Monad m) => MonadState s (StateT s m) where
+>      get   = StateT (\ s -> return (s,s))
+>      put v = StateT (\ _ -> return ((),v))
+> 
+> instance MonadTrans (StateT s) where
+>    lift f = StateT ( \ s -> do { r <- f ; runStateT (return r) s })
+
+> mapStateT :: (m (a,s) -> n (b,s)) -> StateT s m a -> StateT s n b
+> mapStateT f m = StateT (f . runStateT m)
+> 
+> evalStateT :: (Monad m) => StateT s m a -> s -> m a
+> evalStateT m s =  
+>      do (r,_) <- runStateT m s
+>         return r
+> 
+> execStateT :: (Monad m) => StateT s m a -> s -> m s
+> execStateT m s =  
+>      do (_,s) <- runStateT m s
+>         return s
+
+------------------------------------------------------------------------------
+
+
diff --git a/spectral/cryptarithm2/MonadTrans.hs b/spectral/cryptarithm2/MonadTrans.hs
new file mode 100644 (file)
index 0000000..40fe489
--- /dev/null
@@ -0,0 +1,15 @@
+-- This file is understood to be in the public domain.\r
+\r
+module MonadTrans where\r
+\r
+\r
+{-\r
+ - This provides a way of accessing a monad that is inside\r
+ - another monad.\r
+ -}\r
+\r
+class MonadTrans t where\r
+   lift :: Monad m => m a -> t m a\r
+\r
+--liftTrans :: (MonadTrans t) => (a -> t m b) -> (t m a -> t m b)\r
+--liftTrans f m = do { a <- m ; f a }\r
diff --git a/spectral/cryptarithm2/cryptarithm2.stdout b/spectral/cryptarithm2/cryptarithm2.stdout
new file mode 100644 (file)
index 0000000..91fa155
--- /dev/null
@@ -0,0 +1,10 @@
+W => 3
+H => 9
+N => 8
+I => 4
+L => 7
+R => 2
+V => 6
+T => 1
+E => 0
+Y => 5