-------------------------------------------------------------------------------
	       Software Tools for Discrete Mathematics
		   Cordelia Hall and John O'Donnell
-------------------------------------------------------------------------------

Last modified: August 29, 2000
(version of April 2000, by Cordelia Hall and John O'Donnell
 corrections and extensions by Pierre Lemaire, ENSIMAG
 -- see 'extension2.readme' for details)

This software is intended to be used with the book "Discrete
Mathematics Using a Computer", by Cordelia Hall and John O'Donnell,
which was published by Springer in January, 2000.  Softcover, ISBN
1-85233-089-9.

The software is written in Haskell 98, the standard functional
programming language.  It runs interactively under the Hugs 98
implementation.  Under Unix, you can start hugs with the command

  hugs -98

which tells it to use the standard Haskell 98 language, but not the
experimental language extensions.

Notice: the option -c may need to be modified so as this file be loaded.  -- *2
If there is problem when loading this file, use the command:              -- *2
                      :set "-c50"
Note (rlp 6Feb02): Trailing comments starting with "--*" didn't work      --rlp
                   on Linux. So, I changed these to start with "-- *"     --rlp

This software, and its documentation, can be downloaded from the book
web page:

	    www.dcs.gla.ac.uk/~jtod/discrete-mathematics/

It's a good idea to check the web page periodically to keep the
software up to date.

The program is a "literate script".  Each line that begins with "> "
is Haskell source code that can be executed; all other lines are
documentation which will be ignored by the compiler.

> module Stdm where

-------------------------------------------------------------------------------
			 Operator Precedence
-------------------------------------------------------------------------------

> infixl 1 <=>
> infixr 2 ==>
> infixl 3 \/
> infixl 4 /\
> infixl 3 +++
> infixl 4 ~~~
> infixl 4 ***
> infixl 5 !!!

-------------------------------------------------------------------------------
		   Chapter 2.  Propositional Logic
-------------------------------------------------------------------------------


> (<=>) :: Bool -> Bool -> Bool
> (<=>) a b = a == b

> (==>) :: Bool -> Bool -> Bool
> (==>) True False = False
> (==>) a b = True

> (\/) = (||)

> (/\) = (&&)

-------------------------------------------------------------------------------
  A Mini-tutorial on Using the Proof Checker for Propositional Logic
-------------------------------------------------------------------------------

And Introduction
~~~~~~~~~~~~~~~~

Here is a theorem and a valid proof using the And Introduction rule:

Theorem AI1.  q,r  |-  q&r

> thAI1 = Theorem [Q,R] (Q `And` R)
> prAI1 = AndI (Assume Q, Assume R) (And Q R)

To check that Proof prAI1 is a valid proof of Theorem thAI1, execute
the following expression interactively:

	check_proof thAI1 prAI1

The next theorem is similar, but it's incorrect because Q `And` S
doesn't follow from assuming Q and R.

Theorem AI2.  q,r  |-  q&s

Here are the theorem and an invalid proof of it, using the And
Introduction rule incorrectly.

> thAI2 = Theorem [Q,R] (Q `And` S)
> prAI2 =
>   AndI (Assume Q, Assume R)
>        (And Q S)

Try it out with the proof checker by evaluating the following
interactively:

	check_proof thAI2 prAI2

And Elimination (Left)
~~~~~~~~~~~~~~~~~~~~~~

Here is a theorem and a valid proofs using And Elimination (Left).
Test it by evaluating

	check_proof thAEL1 prAEL1

Theorem AEL1.  p&q |-  p

> thAEL1 = Theorem [P `And` Q] P
> prAEL1 = AndEL (Assume (And P Q)) P

This is a slightly more complex theorem, again with a valid proof
using And Elimination (Left).  Check it with

	check_proof thAEL2 prAEL2

Theorem AEL2.  (P|Q)&R |- (P|Q)

> thAEL2 = Theorem [(P `Or` Q) `And` R] (P `Or` Q)
> prAEL2 = AndEL (Assume (And (Or P Q) R)) (Or P Q)

Now we try some invalid proofs.  Consider the following theorem, the
theorem itself is valid but its proof is incorrect.  Check it by
evaluating the expression check_AEL3; the proof checker will tell you
exactly what is wrong with the proof.  Notice that we're moving to a
slightly more concise style, where we aren't naming both the theorem
and the proof separately.

Theorem AEL3.  p&q |-  p

> check_AEL3 =
>   check_proof
>     (Theorem [P `And` Q] P)
>    (AndEL (Assume (Or P Q)) P)

> p6 = -- p&q  |-  p
>   AndEL (Assume (And P Q)) Q
> p7 = -- P&Q  |-  R
>   AndEL (Assume (And P Q)) R

And Elimination (Right)
~~~~~~~~~~~~~~~~~~~~~~~

The following theorem and proof are correct; they are the mirror image
of the AEL1 example above.

> check_AER1 =
>   check_proof
>     (Theorem [P `And` Q] Q)
>     (AndER (Assume (P `And` Q)) Q)

This example is similar; the theorem is ok and the proof would be
valid if it used the AndEL rule, but the AndER rule does not justify
the conclusion, so the proof fails to establish the theorem.

> check_AER2 =
>   check_proof
>     (Theorem [P `And` Q] Q)
>     (AndER (Assume (P `And` Q)) P)

Imply Introduction
~~~~~~~~~~~~~~~~~~

Theorem II1.  Q |- P => P&Q

> check_II1 =
>   check_proof
>     (Theorem [Q] (P `Imp` (P `And` Q)))
>     (ImpI (AndI (Assume P, Assume Q)
>                 (And P Q))
>           (Imp P (And P Q)))


Theorem II2.  |- Q => (P => (P&Q))

> check_II2 =
>   check_proof
>     (Theorem [] (Q `Imp` (P `Imp` (P `And` Q))))
>     (ImpI (ImpI (AndI (Assume P, Assume Q)
>                       (And P Q))
>                 (Imp P (And P Q)))
>           (Imp Q (Imp P (And P Q))))

Imply Elimination
~~~~~~~~~~~~~~~~~

Theorem IE1.  P, P=>Q  |-  Q

> check_IE1 =
>   check_proof
>     (Theorem [P, P `Imp` Q] Q)
>     (ImpE (Assume P, Assume (Imp P Q))
>           Q)


Or Introduction (Left)
~~~~~~~~~~~~~~~~~~~~~~

Theorem OEL1.  P&Q |- P&Q \/ S&P

> check_OIL1 =
>   check_proof
>     (Theorem [P `And` Q, Q `And` R]
>              ((P `And` Q) `Or` (S `And` P)))
>     (OrIL (Assume (P `And` Q))
>           ((P `And` Q) `Or` (S `And` P)))

Or Introduction (Right)
~~~~~~~~~~~~~~~~~~~~~~~

Theorem OIR1.  ~S |- P \/ ~S

> check_OIR1 =
>   check_proof
>     (Theorem [Not S] (P `Or` (Not S)))
>     (OrIR (Assume (Not S))
>           (P `Or` (Not S)))

Identity
~~~~~~~~

> check_ID0 =
>   check_proof
>     (Theorem [P `And` Q] (P `And` Q))
>     (Assume (P `And` Q))

Now the same is proved using the ID inference rule.

Theorem ID1.  P&Q |- P&Q

> check_ID1 =
>   check_proof
>     (Theorem [P `And` Q] (P `And` Q))
>     (ID (Assume (P `And` Q)) (P `And` Q))
 

Contradiction
~~~~~~~~~~~~~

Theorem CTR1.  False |- P & ~P

> check_CTR1 =
>   check_proof
>     (Theorem [FALSE] (P `And` (Not P)))
>     (CTR (Assume FALSE) (P `And` (Not P)))

The next theorem isn't valid, because the premise P isn't enough to
establish P & ~P, and it isn't FALSE so the Contradiction inference
rule doesn't apply.

Theorem CTR2.  P |- P & ~P

> check_CTR2 =
>   check_proof
>     (Theorem [P] (P `And` (Not P)))
>     (CTR (Assume P) (P `And` (Not P)))

Reductio ab Absurdum
~~~~~~~~~~~~~~~~~~~~

Theorem RAA1.  ~~P |- P

> check_RAA1 =
>   check_proof
>     (Theorem [P `Imp` FALSE, (P `Imp` FALSE) `Imp` FALSE]
>              P)
>     (RAA (ImpE (Assume (P `Imp` FALSE),
>                Assume ((P `Imp` FALSE) `Imp` FALSE))
>                FALSE)
>          P)

Examples from the book
~~~~~~~~~~~~~~~~~~~~~~

Here is the theorem and  proofs that are used in the book;
run them like this:
   check_proof example_theorem example_proof1     (should be valid)
   check_proof example_theorem example_proof2     (should give error message)

> example_theorem :: Theorem
> example_theorem =
>   Theorem
>     []
>     (Imp Q (Imp (And P R) (And R Q)))

> example_proof1 =
>   ImpI
>     (ImpI
>        (AndI
>           ((AndER
>               (Assume (And P R))
>               R),
>             Assume Q)
>           (And R Q))
>        (Imp (And P R) (And R Q)))
>     (Imp Q (Imp (And P R) (And R Q)))

The following proof is incorrect proof, because Q^R was inferred where
R^Q was needed.

> example_proof2 =
>   ImpI
>     (ImpI
>        (AndI
>           (Assume Q,
>            (AndER
>               (Assume (And P R))
>               R))
>           (And R Q))
>        (Imp (And P R) (And R Q)))
>     (Imp Q (Imp (And P R) (And R Q)))


-------------------------------------------------------------------------------
     Implementation of the Proof Checker for Propositional Logic
-------------------------------------------------------------------------------

> data Prop
>   = FALSE
>   | TRUE
>   | A | B | C | D | E | G | H | I | J | K | L | M
>   | N | O | P | Q | R | S | U | V | W | X | Y | Z
>   | Pvar String
>   | And Prop Prop
>   | Or Prop Prop
>   | Not Prop
>   | Imp Prop Prop
>   deriving Show      -- Eq is not derived anymore, but completly defined-- *1

> data Theorem
>   = Theorem [Prop] Prop
>   deriving (Eq,Show)

> type TheoremDB = [String]  -- a representation of all the known theorems-- *2

> data Proof
>   = Assume Prop
>   | AndI (Proof,Proof) Prop
>   | AndEL Proof Prop
>   | AndER Proof Prop
>   | OrIL Proof Prop
>   | OrIR Proof Prop
>   | OrE (Proof,Proof,Proof) Prop
>   | ImpI Proof Prop
>   | ImpE (Proof,Proof) Prop
>   | ID Proof Prop
>   | CTR Proof Prop
>   | RAA Proof Prop
>   | Use Theorem [Proof] Prop                                            -- *2
>   | UseTh (Theorem,Proof) [Proof] Prop                                  -- *2
>   | UseDB Theorem [Proof] Prop                                          -- *2
>   deriving (Eq,Show)

When a proof is checked, several pieces of information are gathered
together into a data structure called Status.

> type Status =
>   (Bool,       -- True iff the proof is valid
>    [String],   -- messages describing errors found in the proof
>    [Prop],     -- undischarged assumptions required by the proof
>    Prop)       -- conclusion

-------------------- definition of the Eq for a Prop ------------------------*1

> instance Eq Prop where                                                  -- *1
> -- the basic definitions for the equality:                              -- *1
>    (==) FALSE       FALSE             = True                            -- *1
>    (==) TRUE        TRUE              = True                            -- *1
>    (==) A           A                 = True                            -- *1
>    (==) B           B                 = True                            -- *1
>    (==) C           C                 = True                            -- *1
>    (==) D           D                 = True                            -- *1
>    (==) E           E                 = True                            -- *1
>    (==) G           G                 = True                            -- *1
>    (==) H           H                 = True                            -- *1
>    (==) I           I                 = True                            -- *1
>    (==) J           J                 = True                            -- *1
>    (==) K           K                 = True                            -- *1
>    (==) L           L                 = True                            -- *1
>    (==) M           M                 = True                            -- *1
>    (==) N           N                 = True                            -- *1
>    (==) O           O                 = True                            -- *1
>    (==) P           P                 = True                            -- *1
>    (==) Q           Q                 = True                            -- *1
>    (==) R           R                 = True                            -- *1
>    (==) S           S                 = True                            -- *1
>    (==) U           U                 = True                            -- *1
>    (==) V           V                 = True                            -- *1
>    (==) W           W                 = True                            -- *1
>    (==) X           X                 = True                            -- *1
>    (==) Y           Y                 = True                            -- *1
>    (==) Z           Z                 = True                            -- *1
>    (==) (Pvar x1)   (Pvar x2)         = x1 == x2                        -- *1
>    (==) (And x1 y1) (And x2 y2)       = (x1 == x2) && (y1 == y2)        -- *1
>    (==) (Or x1 y1)  (Or x2 y2)        = (x1 == x2) && (y1 == y2)        -- *1
>    (==) (Not x)     (Not y)           = (x == y)                        -- *1
>    (==) (Imp x1 y1) (Imp x2 y2)       = (x1 == x2) && (y1 == y2)        -- *1
>                                                                         -- *1
> -- the definitions of (Not A) and TRUE                                  -- *1
>    (==) TRUE        (Imp FALSE FALSE) = True                            -- *1
>    (==) (Imp FALSE FALSE)        TRUE = True                            -- *1
>    (==) (Not x1)                   x2 = ((Imp x1 FALSE) == x2)          -- *1
>    (==) x1                   (Not x2) = (x1 == (Imp x2 FALSE))          -- *1
>                                                                         -- *1
> -- all other cases: there is not equality:                              -- *1
>    (==) _           _                 = False                           -- *1
>                                                                         -- *1
> -- definition of inequality, very basic...                              -- *1
>    (/=) x y = not (x == y)                                              -- *1

----------------------------- auxilary functions ---------------------------- *
 
  'setelem' was deleted (use 'elem' instead)                              -- *
  'jsubset' was deleted, and it's not needed anymore                      -- *

> union :: Eq a => [a] -> [a] -> [a]                                       
> union xs ys = xs ++ [y | y <- ys, notElem y xs]                         -- *

> setdif :: Eq a => [a] -> [a] -> [a]
> setdif xs ys = [x | x <- xs, notElem x ys]                              -- *

> putmessages :: [String] -> IO ()                                        -- *
> putmessages []     = return ()                                          -- *
> putmessages (x:xs) = do putStr (" ." ++ x)                              -- *
>                         putmessages xs                                  -- *

> putassumptions :: [Prop] -> IO ()                                       -- *
> putassumptions []     = return ()                                       -- *
> putassumptions (x:[]) = do putStr (show x)                              -- *
>                            putassumptions []                            -- *
> putassumptions (x:xs) = do putStr (show x ++ ", ")                      -- *
>                            putassumptions xs                            -- *

------------------------------ the proof-checker ---------------------------- *

  the following 'check_proof' is equivalent to the 'check_proof' of the   -- *2
  previous versions.                                                      -- *2

> check_proof :: Theorem -> Proof -> IO ()                                -- *2
> check_proof t p =                                                       -- *2
>   do check_proof_with_db [] t p                                         -- *2
>      return ()                                                          -- *2

> check_proof_with_db :: TheoremDB -> Theorem -> Proof -> IO (Bool)       -- *2
> check_proof_with_db db (Theorem thas thc) proof =                       -- *2
>   do let (valid, ms, uda, concl) = traverse db proof                    -- *2
>      let missingassum = setdif uda thas                                  -- *
>      let uselessassum = setdif thas uda                                  -- *
>      let allok = valid && (missingassum == []) && (concl == thc)         -- *
>      if allok                                                            -- *
>        then do putStr "The proof is valid\n"                             -- *
>                if (uselessassum == [])                                   -- *
>                  then putStr ""                                          -- *
>                  else do putStr "notice: these assumptions are useless: "-- *
>                          putassumptions uselessassum                     -- *
>                          putStr "\n"                                     -- *
>        else do putStr "*** The proof is NOT valid ***\n"                 -- *
>                if valid                                                  -- *
>                  then do putStr "The proof does not match the sequent.\n"-- *
>                          putStr " .what is actually proved is:\n      "  -- *
>                          putassumptions uda                              -- *
>                          putStr ("  |-  " ++ show concl ++ "\n")         -- *
>                          if (missingassum == [])                         -- *
>                            then putStr ""                                -- *
>                            else do putStr (" .these assumptions are used"-- *
>                                           ++ " but not part of the sequ" -- *
>                                           ++ "ent:\n      ")             -- *
>                                    putassumptions missingassum           -- *
>                                    putStr "\n"                           -- *
>                  else do if (ms == [])                                   -- *
>                            then putStr ""                                -- *
>                            else do putStr "Reported errors:\n"           -- *
>                                    putmessages ms                        -- *
>      return (allok)                                                     -- *2

The real work is performed in the traverse function, which has a
separate case for checking each inference rule.  Nearly all the
complexity in the following code results from an attempt to provide
meaningful error messages; if the aim were merely to decide whether a
proof is valid, then the implementation could rely much more on
Haskell's pattern matching mechanism, and everything would be much
more concise.

> traverse :: TheoremDB -> Proof -> Status                                -- *2

> traverse _ (Assume a) = (True, [], [a], a)                              -- *2

> traverse db (AndI (a,b) c) =                                            -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (bvalid, bmsgs, buda, bconcl) = traverse db b                     -- *2
>       (ok, msg) =                                                        -- *
>         case c of                                                        -- *
>	    And p q -> if (p==aconcl) && (q==bconcl)                       -- *
>                        then (True, [])                                   -- *
>                        else (False, [err1])                              -- *
>           otherwise -> (False, [err2])                                   -- *
>       err1 = "AndI: the conclusion (" ++ show c ++ ") is not the "       -- *
>              ++ "logical And of the assumption (" ++ show aconcl         -- *
>              ++ ") with the assumption (" ++ show bconcl ++ ")\n"        -- *
>       err2 = "AndI: the conclusion (" ++ show c ++ ") is not an "        -- *
>              ++ "And expression\n"                                       -- *
>       valid = avalid && bvalid && ok
>       msgs = amsgs ++ bmsgs ++ msg                                       -- *
>       uda = auda `union` buda
>   in  (valid, msgs, uda, c)

> traverse db (AndEL a b) =                                               -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) =
>         case aconcl of
>           And p q -> if p == b then (True,[])
>                                else (False, [err1])
>           otherwise -> (False, [err2])
>       err1 = "AndEL: the left term of And assumption (" ++ show aconcl   -- *
>              ++ ") doesn't match the conclusion (" ++ show b ++  ")\n"   -- *
>       err2 = "AndEL: the assumption (" ++ show aconcl ++ ") is not an "  -- *
>              ++ "And expression\n"                                       -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg
>       uda = auda
>   in (valid, msgs, uda, b)

> traverse db (AndER a b) =                                               -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) =
>         case aconcl of
>           And p q -> if q == b then (True,[])
>                                else (False, [err1])
>           otherwise -> (False, [err2])
>       err1 = "AndER: the right term of And assumption (" ++ show aconcl  -- *
>              ++ ") doesn't match the conclusion (" ++ show b ++  ")\n"   -- *
>       err2 = "AndER: the assumption (" ++ show aconcl ++ ") is not an "  -- *
>              ++ "And expression\n"                                       -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg
>       uda = auda
>   in (valid, msgs, uda, b)

> traverse db (OrIL a b) =                                                -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) =                                                         -- *
>         case b of
>           Or p q -> if aconcl == p then (True,[])
>                                    else (False,[err1])
>           otherwise -> (False,[err2])
>       err1 = "OrIL: the left term of OR conclusion (" ++ show b          -- *
>              ++ ") doesn't match the assumption (" ++ show aconcl        -- *
>              ++ ")\n"                                                    -- *
>       err2 = "OrIL: the conclusion (" ++ show b ++ ") is not an Or "     -- *
>              ++ "expression\n"                                           -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = auda
>   in (valid, msgs, uda, b)

> traverse db (OrIR a b) =                                                -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) =                                                         -- *
>         case b of
>           Or p q -> if aconcl == q then (True,[])
>                                    else (False,[err1])
>           otherwise -> (False,[err2])
>       err1 = "OrIL: the right term of OR conclusion (" ++ show b         -- *
>              ++ ") doesn't match the assumption (" ++ show aconcl        -- *
>              ++ ")\n"                                                    -- *
>       err2 = "OrIL: the conclusion (" ++ show b ++ ") is not an Or "     -- *
>              ++ "expression\n"                                           -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = auda
>   in (valid, msgs, uda, b)

> traverse db (OrE (a,b,c) d) =                                           -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (bvalid, bmsgs, buda, bconcl) = traverse db b                     -- *2
>       (cvalid, cmsgs, cuda, cconcl) = traverse db c                     -- *2
>       (ok,msg,uda) =                                                     -- *
>         case aconcl of                                                   -- *
>           Or p q -> let ok2 = p `elem` buda                              -- *
>                         ok3 = q `elem` cuda                              -- *
>                         ok4 = bconcl == cconcl                           -- *
>                         ok5 = bconcl == d                                -- *
>                     in if ok2 && ok3 && ok4 && ok5                       -- *
>                          then (True,[], auda `union` (buda `setdif` [p]) -- *
>                                              `union` (cuda `setdif` [q]))-- *
>                        else (False,                                      -- *
>                              (if ok2 then [] else [err2 p])              -- *
>                              ++ (if ok3 then [] else [err3 q])           -- *
>                              ++ (if ok4 then if ok5 then [] else [err5]  -- *
>            			   else [err4]),                           -- *
>                              auda `union` buda `union` cuda)             -- *
>           otherwise -> (False, [err1],                                   -- *
>                         auda `union` buda `union` cuda)                  -- *
>       err1 = "OrE: the first term above line (" ++ show aconcl           -- *
>              ++ ") is not an Or expression\n"                            -- *
>       err2 x = "OrE: the left term (" ++ show x ++ ") of the first "     -- *
>                ++ "term above line (" ++ show aconcl ++ ") is not an "   -- *
>                ++ "undischarged assumption of the  proof of the second " -- *
>                ++ "term above line (" ++ show bconcl ++ ")\n"            -- *
>       err3 x = "OrE: the right term (" ++ show x ++ ") of the first "    -- *
>                ++ "term above line (" ++ show aconcl ++ ") is not an "   -- *
>                ++ "undischarged assumption of the proof of the third "   -- *
>                ++ "term above line (" ++ show bconcl ++ ")\n"            -- *
>       err4 = "OrE: the conclusion of the second term above line ("       -- *
>              ++ show bconcl ++ ") doesn't match the conclusion of the "  -- *
>              ++ "third term above line (" ++ show cconcl ++ ")\n"        -- *
>       err5 = "OrE: the conclusion (" ++ show d ++ ") doesn't match the " -- *
>              ++ "conclusion of the second and third term above line ("   -- *
>              ++ show bconcl ++ ")\n"                                     -- *
>       valid = avalid && bvalid && cvalid && ok                           -- *
>       msgs = amsgs ++ bmsgs ++ cmsgs ++ msg                              -- *
>   in (valid, msgs, uda, d)                                               -- *

> traverse db (ImpI a b) =                                                -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) = match b                                                -- *1
>       match x =                                                         -- *1
>         case x of                                                       -- *1
>           Imp p q -> if p `elem` auda && aconcl==q                       -- *
>                        then (True,[])
>                      else if not (p `elem` auda) && aconcl==q            -- *
>                        then (False,[err2])
>                      else if p `elem` auda && aconcl/=q                  -- *
>                        then (False,[err3])
>                      else (False,[err2,err3])
>           Not p -> match (Imp p FALSE)                                  -- *1
>           TRUE -> match (Imp FALSE FALSE)  {-Cast fix-}                 -- *1
>           otherwise -> (False,[err1])
>       err1 = "ImpI: the conclusion (" ++ show b ++ ") is not an "        -- *
>              ++ "implication\n"                                          -- *
>       err2 = "ImpI: the antecedent in (" ++ show b ++ ") is not an "     -- *
>              ++ "undischarged assumption above line\n"                   -- *
>       err3 = "ImpI: the conclusion in (" ++ show b ++ ") doesn't match " -- *
>              ++ "the conclusion above line (" ++ show aconcl ++ ")\n"    -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = case b of
>               Imp p q -> auda `setdif` [p]
>               Not p   -> auda `setdif` [p]                              -- *1
>               TRUE   -> auda `setdif` [FALSE] {-Cast fix-}              -- *1
>               otherwise -> auda
>   in (valid, msgs, uda, b)

> traverse db (ImpE (a,b) c) =                                            -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (bvalid, bmsgs, buda, bconcl) = traverse db b                     -- *2
>       (ok,msg) = match bconcl                                           -- *1
>       match x =                                                         -- *1
>         case x of                                                       -- *1
>           Imp p q ->if aconcl==p && c==q
>                       then (True,[])
>                     else if aconcl/=p && c==q
>                       then (False,[err2])
>                     else if aconcl==p && c/=q
>                       then (False,[err3])
>                     else (False,[err2,err3])
>           Not p -> match (Imp p FALSE)                                  -- *1
>           TRUE -> match (Imp FALSE FALSE)   {-Lemaire fix-}             -- *1
>           otherwise -> (False,[err1])
>       err1 = "ImpE: second term above line (" ++ show bconcl             -- *
>              ++ ") is not an implication\n"                              -- *
>       err2 = "ImpE: first term (" ++ show aconcl ++ ") doesn't match "   -- *
>              ++ " the antecedent of the second term (" ++ show bconcl    -- *
>              ++ ")\n"                                                    -- *
>       err3 = "ImpE: the conclusion (" ++ show c ++ ") doesn't match "    -- *
>              ++ "the conclusion of the second term (" ++ show bconcl     -- *
>              ++ ")\n"
>       valid = avalid && bvalid && ok
>       msgs = amsgs ++ bmsgs ++ msg                                       -- *
>       uda = auda `union` buda
>   in (valid, msgs, uda, c)

> traverse db (ID a c) =                                                  -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) = if aconcl == c                                          -- *
>                    then (True,[])
>                    else (False,[err1])
>       err1 = "ID: the conclusion (" ++ show c ++ ") doesn't match "      -- *
>              ++ "the antecedent (" ++ show aconcl ++ ")\n"               -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = auda                                                         -- *
>   in (valid, msgs, uda, c)                                               -- *

> traverse db (CTR a c) =                                                 -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) = if aconcl == FALSE                                      -- *
>                   then (True,[])
>                   else (False,[err1])
>       err1 = "CTR: the antecedent (" ++ show aconcl ++ ") is not "       -- *
>              ++ "FALSE\n"                                                -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = auda                                                         -- *
>   in (valid, msgs, uda, c)                                               -- *

> traverse db (RAA a c) =                                                 -- *2
>   let (avalid, amsgs, auda, aconcl) = traverse db a                     -- *2
>       (ok,msg) = if not ((c `Imp` FALSE) `elem` auda)                    -- *
>                    then (False, [err1])
>                    else if aconcl /= FALSE
>                         then (False, [err2])
>                         else (True, [])
>       err1 = "RAA: the negation of the conclusion (" ++ show c           -- *
>              ++ ") is not an undischarged assumption of the proof "      -- *
>              ++ "above the line\n"                                       -- *
>       err2 = "RAA: the conclusion (" ++ show aconcl ++ ") of the proof " -- *
>              ++ "above the line is not FALSE\n"                          -- *
>       valid = avalid && ok
>       msgs = amsgs ++ msg                                                -- *
>       uda = auda `setdif` [(c `Imp` FALSE)]                              -- *
>   in (valid, msgs, uda, c)                                               -- *


(everything of chapter 2 that follows has been added as 2nd extension, and-- *2
 every line should be marked with-- *2)                                   -- *2

----------------------- traverse function for 'USE' -------------------------*2

Use assumes that the theorem is correct

> traverse db (Use theo assums concl) =
>   let (oks, msgs, udas, concls) = checkproofs db assums
>       err2 = "Use: the theorem " ++ show theo ++ " cannot be applied "
>              ++ "with the assumptions " ++ show concls
>              ++ " and the conclusion ("++ show concl ++")\n"
>   in if not oks then (False, msgs, udas, concl)
>      else if (usetheorem theo concls concl) then 
>             (True, msgs, udas, concl)
>      else (False, msgs++[err2], udas, concl)


UseDB checks if a theorem can be used by looking for it in a data-base

> traverse db (UseDB theo assums concl) =
>   let (oks, msgs, udas, concls) = checkproofs db assums
>       err1 = "UseDB: there is no known theorem of which name is "
>              ++ show theo ++ "\n"
>       err2 = "UseDB: the theorem " ++ show theo ++ " cannot be applied "
>              ++ "with the assumptions " ++ show concls
>              ++ " and the conclusion ("++ show concl ++")\n"
>   in if not (findtheorem db theo)
>        then (False, msgs++[err1], udas, concl)
>      else if not oks then (False, msgs, udas, concl)
>      else if (usetheorem theo concls concl) then 
>             (True, msgs, udas, concl)
>      else (False, msgs++[err2], udas, concl)

UseTh needs the proof of a theorem to check if it's valid and then can be used.

> traverse db (UseTh (theo,proof) assums concl) =
>       -- check if the theorem is valid
>   let (proofvalid, _, proofuda, proofconcl) = traverse db proof
>       (Theorem thas thc) = theo
>       missingassum = setdif proofuda thas
>       theook = proofvalid && (missingassum == []) && (proofconcl == thc)
>       -- check if the assumptions of the theorems are valid
>       (oks, msgs, udas, concls) = checkproofs db assums
>       err1 = "UseTh: the proof of the theorem " ++ show theo
>              ++ " is not valid and then the theorem cannot be used\n"
>       err2 = "UseTh: the theorem " ++ show theo ++ " cannot be applied "
>              ++ "with the assumptions " ++ show concls
>              ++ " and the conclusion ("++ show concl ++")\n"
>   in if not theook
>        then (False, msgs++[err1], udas, concl)
>      else if not oks then (False, msgs, udas, concl)
>      else if (usetheorem theo concls concl) then 
>             (True, msgs, udas, concl)
>      else (False, msgs++[err2], udas, concl)



the function 'checkproof' check the proofs of every assumptions of the
theorem, and return the list of the conclusions of these proofs, with
their validity, the error messages and the undischarged assumptions

> checkproofs :: TheoremDB -> [Proof] -> (Bool, [String], [Prop], [Prop])
> checkproofs _ [] = (True, [], [], [])
> checkproofs db (x:xs) =
>   let (okx,  msgx,  udasx,  cclx)  = traverse db x
>       (okxs, msgxs, udasxs, cclxs) = checkproofs db xs
>   in (okx && okxs, msgx ++ msgxs, udasx `union` udasxs, cclx:cclxs)

----------------------- the functions to use a theorem ----------------------*2

the function 'findtheorem' looks if a theorem belongs to the data-base of known
theorems.

> findtheorem :: TheoremDB -> Theorem -> Bool
> findtheorem db t =
>   case db of
>     []     -> False
>     (x:xs) -> x == s || findtheorem xs t
>   where s = namefor t

the function 'usetheorem' checks if a theorem can be applied with the given
assumption to reach the given conclusion. Actually, the work is mainly
performed by the function 'unification' 

> usetheorem :: Theorem -> [Prop] -> Prop -> Bool
> usetheorem theo assums concl =
>   let (Theorem thassu thconcl) = theo
>   in unification (thconcl:thassu) (concl:assums)

the function 'unification' try to match the atoms of the first list of
proposition with sub-propositions of the second list

> unification :: [Prop] -> [Prop] -> Bool
> unification l1 l2 =
>   if not (length l1 == length l2)
>     then False
>     else let (ok, _) = unifrec l1 l2 in ok
>   where
>     unifrec :: [Prop] -> [Prop] -> (Bool, [(Prop, Prop)])
>     unifrec [] [] = (True, [])
>     unifrec (x:xs) (y:ys) = 
>       let (okxy, unifxy) = unif x y
>           (oks,  unifs) = unifrec xs ys
>           (oku,  unifu) = addunif unifxy unifs
>       in (okxy && oks && oku, unifu)
>
>     unif :: Prop -> Prop -> (Bool, [(Prop, Prop)])
>     unif x y =
>       case x of
>         TRUE    -> if y == TRUE then (True, [])
>                    else (False, [])
>         FALSE   -> if y == FALSE then (True, [])
>                    else (False, [])
>         And a b -> case y of
>                      And c d -> unifacbd a c b d
>                      otherwise -> (False, [])
>         Or a b  -> case y of
>                      Or c d  -> unifacbd a c b d
>                      otherwise -> (False, [])
>         Not a   -> case y of
>                      Not b       -> unif a b
>                      Imp b FALSE -> unif a b
>                      otherwise -> (False, [])
>         Imp a b -> case y of
>                      Imp c d -> unifacbd a c b d
>                      Not c   -> if b == FALSE then unif a c
>                                 else (False, [])
>         _       -> (True, [(x,y)])
>      where
>          unifacbd a c b d = let (okac, unifac) = unif a c
>                                 (okbd, unifbd) = unif b d
>                                 (oku,  unifu) = addunif unifac unifbd
>                             in (okac && okbd && oku, unifu)
>
>     addunif :: [(Prop,Prop)] -> [(Prop, Prop)] -> (Bool, [(Prop,Prop)])
>     addunif xs [] = (True, xs)
>     addunif xs (y:ys) =
>       let (exp,val) = y
>           setexp = [v | (y,v) <- xs, y == exp]
>       in if setexp == [] then addunif (y:xs) ys
>          else if val == head setexp then addunif xs ys
>          else let (ok, u) = addunif xs ys in (False, u)

the function 'namefor' give a name (String) to a theorem, which does not 
depend on the name givento the variables of the theorem. For example,
(Theorem [A,B] (B `And` A)) and (Theorem [C,D] (D `And` C)) will receive
the same name.

> namefor :: Theorem -> String
> namefor t =
>   let (Theorem assums concl) = t
>       names = name (concl:assums)
>   in write assums names ++ " |- " ++ write [concl] names
>   where
>     name :: [Prop] -> [(Prop,Int)]
>     name xs = zip (atoms xs) [1..]
>     
>     atoms :: [Prop] -> [Prop]
>     atoms [] = []
>     atoms (x:xs) =
>       case x of
>           TRUE  -> atoms xs
>           FALSE -> atoms xs
>           And p q -> ((atoms [p]) `union` (atoms [q])) `union` (atoms xs)
>           Or  p q -> ((atoms [p]) `union` (atoms [q])) `union` (atoms xs)
>           Imp p q -> ((atoms [p]) `union` (atoms [q])) `union` (atoms xs)
>           Not p   -> (atoms [p]) `union` (atoms xs)
>           _       -> [x] `union` (atoms xs)
>
>     write :: [Prop] -> [(Prop,Int)] -> String
>     write [] _ = ""
>     write (x:[]) names = writeprop x names
>     write (x:xs) names = writeprop x names ++ ", " ++ write xs names
>     
>     writeprop :: Prop -> [(Prop,Int)] -> String
>     writeprop x names =
>       case x of
>           TRUE  -> "T"
>           FALSE -> "F"
>           And p q -> "(And " ++ writeprop p names ++ " "
>                              ++ writeprop q names ++ ")"
>           Or  p q -> "(Or "  ++ writeprop p names ++ " "
>                              ++ writeprop q names ++ ")"
>           Imp p FALSE -> writeprop (Not p) names
>           Imp p q -> "(Imp " ++ writeprop p names ++ " "
>                              ++ writeprop q names ++ ")"
>           Not p   -> "(Not " ++ writeprop p names ++ ")"
>           _       -> show (head [s | (a,s) <- names, a == x])

----------------------- functions to read/write the db ----------------------*2

> readtheorems :: String -> TheoremDB
> readtheorems = clear . lines
>   where clear [] = []
>         clear (x:xs) = if x=="" then clear xs else x:clear xs

> writetheorems :: TheoremDB -> String
> writetheorems [] = "\n"
> writetheorems (x:xs) = x ++ "\n" ++ writetheorems xs

------------------------------ user's functions -----------------------------*2

> addNewTheorem :: String -> Theorem  -> Proof -> IO ()
> addNewTheorem filename theo proof =
>   do filedata <- (readFile filename) `catch` (\_ -> return "")
>      let db = readtheorems filedata
>        in do ok <- check_proof_with_db db theo proof
>              if ok && (db == db) -- to force the evaluation of 'db'
>                then do writeFile filename
>                                  (writetheorems
>                                     (db `union` [namefor theo]))
>                        return ()
>                else return ()

> checkProofUsingTheorems :: String -> Theorem -> Proof -> IO ()
> checkProofUsingTheorems filename theo proof =
>   do filedata <- (readFile filename) `catch` (\_ -> return "")
>      check_proof_with_db (readtheorems filedata) theo proof
>      return ()

-------------------------------------------------------------------------------
    Implementation of the Proof Checker for Algebraic Propositional Logic
-------------------------------------------------------------------------------

  * Generic Part *

  **  AlgType **

  AlgType defines the representation of an object in the language the
proof-checker is being used for.

  AlgVar x is a variable named `x'.  It specifically refers to
variables whose value ranges over the entire type a, rather than to
named constants with a specific value specified in the problem.  Named
constants should be expanded and represented by AlgConst.

  AlgConst x is a constant with value `x'.

  AlgExp f args is a function call with value args.  This is used, for
example, for the Imp, And, and Or constructors of propositions.

> data AlgType a = 
>         AlgVar String
>       | AlgConst a
>       | AlgExp String [AlgType a]
>       deriving Eq

  **  AlgProof  **

  AlgProof defines an alleged proof of some theorem.

  AlgEq1 is used as the first statement in a proof.  Its only purpose
is to hold the proposition.  AlgEq and AlgImp are used subsequently in
a proof.  They take the preceding section of the proof and a new
object, together with a theorem tying the last term of the preceding
proof to the new object.  Of course, their application looks allot
better in actual use than in my description.  AlgEq is used to prove
an equality, AlgImp is used to prove an implication.  Additional
constructors may need to be added to support new types; if so, extend
AlgThm and the user-interface functions also.

> data AlgProof a =
>         AlgEq1  (AlgType a)  (AlgType a) (AlgThm a)
>       | AlgEq   (AlgProof a) (AlgType a) (AlgThm a)
>       deriving (Eq, Show)

  **  AlgThm  **

  AlgThm defines both a theorem and a rule for subsequent use.  It is
left to the operator to ensure that only axioms and proven theorems
are used as rules.

  ThmEq asserts the provability of the equality of two objects.


  Additional constructors may need to be added to support new types;
if so, extend AlgProof and the user-interface functions also.

> data AlgThm a =
>         ThmEq  (AlgType a) (AlgType a)
>       deriving Show

  We never care which direction an equational theorem is in, so we
define an explicit instance to define this.

> instance Eq a => Eq (AlgThm a) where
>    (x1 `ThmEq` y1) == (x2 `ThmEq` y2) =    (x1 == x2 && y1 == y2)
>                                         || (x1 == y2 && y1 == x2)
>    _ == _ = False

  **  Algebraic  **

  Algebraic defines the operations required for the rest of this
module to work on objects of a particular type.

  formulate simply transforms an object into its representation.
showsAlg transforms the canonical form of an object into a ShowS
function.

> class Algebraic a where
>        formulate :: a -> AlgType a
>        showsAlg :: AlgType a -> ShowS

  The following functions are user interface functions used
ubiquitously in conjunction with the Algebraic class.  Additional
functions may need to be added to support new types; if so, extend
AlgProof and AlgThm also.

  startProof turns a proposition into a proof in the easiest possible
way.  identity helps make it easy.

> identity :: Algebraic a => AlgThm a
> identity = AlgVar "x" `ThmEq` AlgVar "x"

> startProof :: Algebraic a => a -> AlgProof a
> startProof p = AlgEq1 (formulate p) (formulate p) identity

  eq is a fancy composition of AlgEq and formulate.  The funky
typing is to get the two right-hand arguments to work properly without
fully parenthesizing the expression.  Ditto for the rest.

> eq  :: Algebraic a => AlgProof a -> (a, AlgThm a) -> AlgProof a
> p `eq` (q, thm) = AlgEq p (formulate q) thm

> (<->) :: Algebraic a => AlgProof a -> (a, AlgThm a) -> AlgProof a
> (<->) = eq

> thmEq :: Algebraic a => a -> a -> AlgThm a
> thmEq p q = ThmEq (formulate p) (formulate q)

  We define an explicit Show instance for AlgType, to take advantage
of the showsAlg function above.

> instance Algebraic a => Show (AlgType a) where
>     showsPrec _ = showsAlg

  **  Success  **

  Success is, conceptually, an extension of the Maybe monad to support
error messages.  However, note that, if two operations in a
do-expression or other sequencing fail, only the error messages from
the first will be reported.

> data Success a = Success a
>                  | Failure [String]

  The monad instance for Success is fairly straight-forward.
Successful operations get their values passed on to the next
operation, and unsuccessful operations get their errors returned.  The
next operation gets a cold shoulder.

> instance Monad Success where
>        Success a >>= f = f a
>        Failure errs >>= _ = Failure errs
>        return = Success
>        fail s = Failure [s]

  ** The Proof Checker **

  The Proof Checker is based on a very simple algorithm.  You give it
a proof and a theorem, and it verifies two things:

1.  The proof is correct
2.  It proves the theorem.

  The user entry point to the proof checker is `checkAlgebra'.

  The type of checkAlgebra is:

> checkAlgebra :: (Eq a, Algebraic a) => AlgProof a -> AlgThm a -> IO ()

  This code should be fairly simple.  proofSuccess translates the
Success value and realThm into a user-readable message.

> checkAlgebra (AlgEq1 _ _ _) _ =
>     do
>	putStrLn "A formula is not a proof"
>	putStrLn ("An equational proof must have at least one equation "
>		  ++ "or implication")

> checkAlgebra proof thm = proofSuccess (doCheck proof)
>     where
>       realThm = getThm proof
>       proofSuccess (Success a) = 
>         if realThm == thm then
>           putStrLn "The proof is correct"
>         else do
>             putStrLn ("The proof is correct, but it proves the "
>                       ++ "wrong theorem")
>             putStrLn ("The theorem you have proved is " 
>                       ++ show realThm)
>       proofSuccess (Failure errs) = do
>         putStrLn "The proof is incorrect"
>         putStr (formatErrs errs)

> check_equation :: (Eq a, Algebraic a) => AlgThm a -> AlgProof a -> IO ()

> check_equation t p = checkAlgebra p t

  formatErrs puts a newline after each message, then strings the
results together.  I.e., `formatErrs = concat . map (++ "\n")'.

> formatErrs (err : errs) =
>        err ++ "\n" ++ formatErrs errs

> formatErrs [] = "\n"

  doCheck just does a quick recursive loop over the proof, checking
each step and sequencing the results.  The only wrinkle is dealing
with implication/equality; match provides the correct logic for that.

> doCheck (AlgEq1 a b thm) = match thm
>        where
>             match (ThmEq c d) = checkFwdBkwd a b c d
>             match _ = fail "Cannot prove an equality by an implication"

> doCheck (AlgEq a b thm) = do
>            doCheck a
>            match thm
>        where
>            match (ThmEq c d) = checkFwdBkwd (concl a) b c d
>            match _ = fail "Cannot prove an equality by an implication"


  `Conclusion' definition

> concl (AlgEq1 _ b _) = b
> concl (AlgEq _ b _) = b

  Sub m x means substitute m in for x; that is, if x is a parameter in
a rule, m is the corresponding value in the proof.

> newtype Substitution a = Sub (AlgType a, String)

  This instance provides more intutive error messages.  The logic is
`print (Sub m x) => [m/x]'.

> instance Algebraic a => Show (Substitution a) where
>     showsPrec _ (Sub (a, x)) = ('[':).shows a.('/':).(x ++).(']':)

  checkFwdBkwd's purpose is to check both forward and backward
cases.  If /either/ succeeds, it succeeds.  (I.e., it does /not/
sequence the results).  The `backward case', not having a function of
its own, is implemented as the forward case with the rule backward.

> checkFwdBkwd :: (Algebraic a, Eq a) => 
>        AlgType a -> AlgType a -> AlgType a -> AlgType a -> 
>                Success [Substitution a]

> checkFwdBkwd proofLhs proofRhs ruleLhs ruleRhs = totalSuccess
>     where 
>           totalSuccess = success1 `orSuccess` success2 
>           success1 = checkFwd proofLhs proofRhs ruleLhs ruleRhs 
>           success2 = checkFwd proofLhs proofRhs ruleRhs ruleLhs

  checkFwd checks just the forward case.  The result is, if
successful, the substitutions into the rule necessary to make the
proof work.

  The formal type is:

> checkFwd :: (Eq a, Algebraic a) => AlgType a -> AlgType a -> AlgType a 
>                        -> AlgType a -> Success [Substitution a]

  The logic is: find out what substitutions are needed to make the lhs
of the proof match the lhs of the rule.  Ditto for the rhss.  Then,
check if the two sets of substitutions are compatible.
(foldableSubsUnion performs error checking on its argumnts.)

  If that works, good.  If it fails, and both the left hand and right
hand sides of the proof are functions, and the function is the same in
both cases, try a recursive descent into the arguments.  If every case
succeeds, return a successful result (arguments that don't change will
succeed).  Otherwise, return the first failure.

> checkFwd proofLhs proofRhs ruleLhs ruleRhs = 
>                directSuccess `orSuccess` recurseSuccess
>        where 
>              directSuccess = 
>                 foldableSubsUnion
>                        (enumerateSubs proofLhs ruleLhs) 
>                        (enumerateSubs proofRhs ruleRhs)
>              recurseSuccess = recurse proofLhs proofRhs
>              recurse (AlgExp f args1) (AlgExp g args2)
>                | f == g && length args1 == length args2 
>                        = foldr (>>) (return []) -- Check all arguments
>                                (zipWith doRecurse args1 args2)
>                | otherwise 
>                        = diffForm (AlgExp f args1) (AlgExp g args2)
>              recurse x y | x == y = return [] -- Identity law
>                          | otherwise = diffForm x y
>              doRecurse proofLhs' proofRhs' = 
>                checkFwd proofLhs' proofRhs' ruleLhs ruleRhs
>              diffForm x y = fail ("Terms " ++ show x ++ " and " 
>                            ++ show y ++ " cannot be equal:\n\tthey do "
>                            ++ "not match the rule and they have "
>                            ++ "different form")

  orSuccess performs the same result for Success values as || does
for Bools: it returns a success if it can find one, otherwise it
returns a failure.  Specifically, if confronted with two successes, it
returns the first.  If confronted with two failures, it returns their
concatenation.  If confronted with a success and a failure, it returns
the success.

> orSuccess :: Success a -> Success a -> Success a

> orSuccess (Success x) _ = Success x
> orSuccess _ (Success y) = Success y
> orSuccess (Failure errs1) (Failure errs2) = 
>     Failure (errs1 ++ errs2) -- Dump everything on 'em

  enumerateSubs returns the substitutions required to make its second
argument identical to its first argument, if any.  Otherwise, it
reports why it couldn't find any.

> enumerateSubs :: (Eq a, Algebraic a) => AlgType a -> AlgType a 
>                                -> Success [Substitution a]

  This is the most complicated case.  If the two functions are the
same (and there are the same number of arguments), we first match up
each argument recursively.  Then, foldableSubsUnion makes sure the
substitutions are all compatible with each other.

> enumerateSubs (AlgExp f args1) (AlgExp g args2) 
>        | f == g && length args1 == length args2
>                    = foldr foldableSubsUnion (return []) 
>                        (zipWith enumerateSubs args1 args2)
>        | otherwise = fail ("Cannot find a substitution into " 
>                    ++ show (AlgExp g args2) ++ " yeilding " 
>                    ++ show (AlgExp f args1) 
>                    ++ ":\n\tThey have different form")

  These two cases are simpler.  The first does the work of introducing
substitutions when we've recursed down to a variable on the right.
The second introduces failures when we have a constant on the right
and an unequal constant on the left.

> enumerateSubs m (AlgVar x) = Success [Sub (m, x)]
> enumerateSubs a b
>        | a == b    = return [] -- No substitutions are necessary
>        | otherwise = fail ("Cannot find a substitution into " 
>                            ++ show b ++ " yeilding " ++ show a)

  getThm takes a proof and reports what, if anything, the proof
proves.  More precisely, on the assumption that the proof is correct,
getThm returns what the proof proves.  For example, given:

proof = beginProof FALSE
            `eq` (TRUE, deMorgansLawOr)

`getThm proof' returns `FALSE `ThmEq` (FALSE `Imp` FALSE)'.  The
proof is incorrect, but if it were correct that would be what it
proved.

> getThm (AlgEq1 a b stuff) = a `ThmEq` b

> getThm (AlgEq a b stuff) = thmComb aThm
>        where
>                aThm = getThm a
>                thmComb (realHypot `ThmEq` _) = realHypot `ThmEq` b


  foldableSubsUnion does two jobs: it error-checks its arguments,
and it has a type compatible with `a -> b -> b', so it can be used
with foldr, hence the name `foldable'.  The actual code is trivial.

> foldableSubsUnion success1 success2 =
>        do  subs1 <- success1
>            subs2 <- success2
>            subsUnion subs1 subs2

   subsUnion's job is to take two sets of substitutions and reconcile
them, on the assumption they're internally consistent.  If one views
[Substitution a] as the extension of a function of type String -> a,
this function implements the set union function *maintaining the
function property*, and returning an error if that proves impossible.
We do an induction over the first set, searching the second set for
the variable assigned.  If it isn't found, we just add the
substitution at the front of our result, and return success.  If the
variable is found, we check to see if the term substitutions2 assigns
to it is equal to the term assigned by substitutions1.  If the two
subs don't fit, we return an error.

  At several points in the code, do-notation is used to mask
error-checking.  This appears to create a slight inconsistency, since
the right-most error is reported, unlike the general tendency of this
code (to report as many errors as possible, but if a choice has to be
made, report the left errors).  Fortunately, the right-hand errors are
ignored if we generate an error.  So only the first error gets
reported.  (Of course, this means if you fix every error message we
generate, there may still be detectible errors.  Welcome to C.S.).

> subsUnion (Sub (xterm, xvar) : substitutions1) substitutions2 =
>        case (find xvar substitutions2) of
>                Nothing -> do
>                             subs <- recurse -- Check the recursive
>                                             -- case for errors
>                             return (Sub (xterm, xvar) : subs)
>                Just (yterm, yvar) ->
>                        if (yterm == xterm) then
>                                recurse -- No need to change anything
>                        else do -- Skip the recursion; just fail
>                                -- (returning the left-most error)
>                                fail ("The substitutions " 
>                                  ++ show (Sub (yterm, yvar)) ++ " and " 
>                                  ++ show (Sub (xterm, xvar)) 
>                                  ++ " do not match")
>        where   
>                recurse = subsUnion substitutions1 substitutions2
>                find xvar (Sub (yterm, yvar) : ys)
>                        | xvar == yvar = Just (yterm, yvar)
>                        | otherwise    = find xvar ys
>                find xvar [] = Nothing

  The base case is easy.  It always succeeds, returning just the
substitutions on the right.

> subsUnion [] substitutions2 = return substitutions2

  -- End of Generic Part of Algebraic Propositional Proof Checker --

  * Prop-Specific Part of Algebraic Propositional Proof Checker *

  Allow the algebraic proof checker to work with Prop.

> instance Algebraic Prop where

  formulate takes a proposition.  It expands definitions (Not, TRUE).
Then, a single case (in pattern matching, for example) can handle all
`equal' propositions.  Our concept of equality is similar, but not
identical, to the defined (==) operator for Prop.  formulate also
converts functions (Or, And, Imp) to AlgExp "fn".  Then, a single case
can handle all functions, and the == operator for String can compare
two expressions to see if they have the same operator.

 * Forms involving Not *

  These are definitions.  We expand the definitions and translate them
into AlgType here.

>       formulate (Not a) = 
>               AlgExp "Imp" [(formulate a), AlgConst FALSE]

>       formulate TRUE = 
>               AlgExp "Imp" [AlgConst FALSE, AlgConst FALSE]

 * Propositional Variables *

(T and F omitted from Prop for clarity):

  These are converted to AlgVar, so we can handle variables
consistently

>       formulate A = AlgVar "A"
>       formulate B = AlgVar "B"
>       formulate C = AlgVar "C"
>       formulate D = AlgVar "D"
>       formulate E = AlgVar "E"

        formulate F omitted

>       formulate G = AlgVar "G"
>       formulate H = AlgVar "H"
>       formulate I = AlgVar "I"
>       formulate J = AlgVar "J"
>       formulate K = AlgVar "K"
>       formulate L = AlgVar "L"
>       formulate M = AlgVar "M"
>       formulate N = AlgVar "N"
>       formulate O = AlgVar "O"
>       formulate P = AlgVar "P"
>       formulate Q = AlgVar "Q"
>       formulate R = AlgVar "R"
>       formulate S = AlgVar "S"

        formulate T omitted

>       formulate U = AlgVar "U"
>       formulate V = AlgVar "V"
>       formulate W = AlgVar "W"
>       formulate X = AlgVar "X"
>       formulate Y = AlgVar "Y"
>       formulate Z = AlgVar "Z"

 * Propositional operators *

  We recursively define these.  The operators need translation to
`AlgExp' form, and their operands also need translation.
        
>       formulate (Or a b) = AlgExp "Or" [formulate a, formulate b]
>       formulate (And a b) = AlgExp "And" [formulate a, formulate b]
>       formulate (Imp a b) = AlgExp "Imp" [formulate a, formulate b]

 * Propositional constants *

  These don't need expansion or recursive definitions.

>       formulate FALSE = AlgConst FALSE
>       formulate (Pvar a) = AlgVar a

  Next, we define the functions necessary for an explicit Show
instance for AlgType Prop, to aid in error reporting.

>       showsAlg (AlgVar x) = (x ++)
>       showsAlg (AlgConst FALSE) = ("FALSE" ++)
>       showsAlg (AlgExp "Imp" [AlgConst FALSE, AlgConst FALSE]) = 
>                       ("TRUE" ++)
>       showsAlg (AlgExp "Imp" [a, AlgConst FALSE]) = 
>                       ("(Not " ++).showsAlg a.(')' :)
>       showsAlg (AlgExp f [p, q]) = 
>                     ('(' :).shows p.(" `" ++).(f ++).("` " ++).
>                     shows q.(')':)

  Following are the boolean algebra laws.  They are also intended as
examples of how to use the AlgChecker functions.  (Note that the
AlgChecker code itself tends to assume a rather unreadable canonical
form.  This illustrates how to do things in a human-readable form.)

  Null and identity laws

> andNull = (A `And` FALSE) `thmEq` FALSE
> orNull = (A `Or` TRUE) `thmEq` TRUE
> andID = (A `And` TRUE) `thmEq` A
> orID = (A `Or` FALSE) `thmEq` A

  Basic properties

> andIdempotent = (A `And` A) `thmEq` A
> orIdempotent = (A `Or` A) `thmEq` A
> andComm = (A `And` B) `thmEq` (B `And` A)
> orComm = (A `Or` B) `thmEq` (B `Or` A)
> andAssoc = ((A `And` B) `And` C) `thmEq` (A `And` (B `And` C))
> orAssoc = ((A `Or` B) `Or` C) `thmEq` (A `Or` (B `Or` C))

  Distributivity laws

> andDistOverOr =         (A `And` (B `Or` C)) 
>               `thmEq` ((A `And` B) `Or` (A `And` C))
> orDistOverAnd =         (A `Or` (B `And` C))
>               `thmEq` ((A `Or` B) `And` (A `Or` C))

  Laws Concerning Not

> deMorgansLawAnd = (Not (A `And` B)) `thmEq` (Not A `Or` Not B)
> deMorgansLawOr = (Not (A `Or` B)) `thmEq` (Not A `And` Not B)
> negTrue = Not TRUE `thmEq` FALSE
> negFalse = Not FALSE `thmEq` TRUE
> andCompl = (A `And` Not A) `thmEq` FALSE
> orCompl = (A `Or` Not A) `thmEq` TRUE
> dblNeg = (Not (Not A)) `thmEq` A

  Implication Laws

> currying = ((A `And` B) `Imp` C) `thmEq` (A `Imp` (B `Imp` C))
> implication = (A `Imp` B) `thmEq` ((Not A) `Or` B)
> contrapositive = (A `Imp` B) `thmEq` ((Not B) `Imp` (Not A))
> absurdity = ((A `Imp` B) `And` (A `Imp` Not B)) `thmEq` (Not A)


 * Examples *

  Prove Or Complement given And Complement:

> orComplProof = startProof TRUE
>               `eq`       (Not FALSE, negFalse)
>               `eq`       (Not (A `And` Not A), andCompl)
>               `eq`       (Not A `Or` Not (Not A), deMorgansLawAnd)
>               `eq`       (Not A `Or` A, dblNeg)
>               `eq`       (A `Or` Not A, orComm)

  Incorrect Theorem (We foget the Not in negFalse):

> orComplProofIncorr = startProof TRUE
>                     `eq`       (FALSE, negFalse)
>                     `eq`       (Not (A `And` Not A), andCompl)
>                     `eq`       (Not A `Or` Not (Not A), deMorgansLawAnd)
>                     `eq`       (Not A `Or` A, dblNeg)
>                     `eq`       (A `Or` Not A, orComm)

  -- End of Prop-specific part of Algebraic Propositional Proof Checker --

-------------------------------------------------------------------------------
		     Chapter 3.  Predicate Logic
-------------------------------------------------------------------------------

> forAll :: [Int] -> (Int -> Bool) -> Bool
> forAll u p = all p u

> exists :: [Int] -> (Int -> Bool) -> Bool
> exists u p = any p u


-------------------------------------------------------------------------------
			Chapter 4.  Set Theory
-------------------------------------------------------------------------------

> type Set a = [a]

> errfun :: Show a => String -> a -> String -> b
> errfun f s msg = error (f ++ ": " ++ show s ++ " is not a " ++ msg)

note that subset does not reject non-sets

> subset :: (Eq a, Show a) => Set a -> Set a -> Bool
> subset set1 set2 
>      = foldr f True set1
>        where 
>        f x sofar = if elem x set2 then sofar else False

> -- note that properSubset does not reject non-sets
> properSubset :: (Eq a, Show a) => Set a -> Set a -> Bool
> properSubset set1 set2
>      = not (setEq set1 set2) /\ (subset set1 set2)

> -- note that setEq does not reject non-sets
> setEq :: (Eq a, Show a) => Set a -> Set a -> Bool
> setEq set1 set2 
>      = (set1 `subset` set2) /\ (set2 `subset` set1)

> normalForm :: (Eq a, Show a) => [a] -> Bool
> normalForm set = length (normalizeSet set) == length set

> normalizeSet :: Eq a => [a] -> Set a
> normalizeSet elts 
>      = foldr f [] elts
>        where
>        f x sofar 
>          = if x `elem` sofar then sofar else x:sofar

> (+++) :: (Eq a, Show a) => Set a -> Set a -> Set a
> (+++) set1 set2 
>      = if not (normalForm set1)
>           then errfun "+++" set1 "set"
>           else if not (normalForm set2)
>                then errfun "+++" set2 "set"
>                else normalizeSet (set1 ++ set2)

> (***) :: (Eq a, Show a) => Set a -> Set a -> Set a
> (***) set1 set2
>      = if not (normalForm set1)
>           then errfun "***" set1 "set"
>           else if not (normalForm set2)
>                then errfun "***" set2 "set"
>                else [x | x <- set1, (x `elem` set2)]

> (~~~) :: (Eq a, Show a) => Set a -> Set a -> Set a
> (~~~) set1 set2 
>      =  if not (normalForm set1)
>            then errfun "~~~" set1 "set"
>            else if not (normalForm set1)
>                 then errfun "~~~" set2 "set"
>                 else [x | x <- set1, not (x `elem` set2)]

> (!!!) :: (Eq a, Show a) => Set a -> Set a -> Set a
> (!!!) u a = if not (normalForm u)
>                then errfun "!!!" u "set"
>                else
>             if not (normalForm a)
>                then errfun "!!!" a "set"
>             else u ~~~ a

> powerset :: (Eq a, Show a) => Set a -> Set (Set a)
> powerset set
>  = if not (normalForm set)
>       then errfun "powerset" set "set"
>    else
>    powersetLoop set
>    where
>    powersetLoop [] = [[]]
>    powersetLoop (e:set)
>      = let setSoFar = powersetLoop set
>        in [e:s | s <- setSoFar] ++ setSoFar

> crossproduct :: (Eq a, Show a, Eq b, Show b) => Set a ->
>                   Set b -> Set (a,b)
> crossproduct set1 set2
>  = if not (normalForm set1)
>       then errfun "crossproduct" set1 "set"
>    else
>    if not (normalForm set2)
>       then errfun "crossproduct" set2 "set"
>    else [(a,b) | a <- set1, b <- set2]


-------------------------------------------------------------------------------
			Chapter 5.  Recursion
-------------------------------------------------------------------------------

> factorial :: Integer -> Integer
> factorial 0 = 1
> factorial (n+1) = (n+1) * factorial n

> quicksort :: Ord a => [a] -> [a]
> quicksort [] = []
> quicksort (splitter:xs) =
>   quicksort [y | y <- xs, y<=splitter]
>   ++ [splitter]
>   ++ quicksort [y | y <- xs, y>splitter]

> firsts1, firsts2 :: [(a,b)] -> [a]
> firsts1 [] = []
> firsts1 ((a,b):ps) = a : firsts1 ps

> firsts2 xs = map fst xs

> data Tree a
>   = Tip
>   | Node a (Tree a) (Tree a)
>   deriving Show

> t1, t2 :: Tree Int
> t1 = Node 6 Tip Tip
> t2 = Node 5
>        (Node 3 Tip Tip)
>        (Node 8 (Node 6 Tip Tip) (Node 12 Tip Tip))

> nodeCount :: Tree a -> Int
> nodeCount Tip = 0
> nodeCount (Node x t1 t2) = 1 + nodeCount t1 + nodeCount t2

> reflect :: Tree a -> Tree a
> reflect Tip = Tip
> reflect (Node a t1 t2) = Node a (reflect t2) (reflect t1)

> mapTree :: (a->b) -> Tree a -> Tree b
> mapTree f Tip = Tip
> mapTree f (Node a t1 t2) =
>   Node (f a) (mapTree f t1) (mapTree f t2)

> tree :: Tree (Int,Int)
> tree =
>   Node (5,10)
>     (Node (3,6)  (Node (1,1) Tip Tip)
>                  (Node (4,8) Tip Tip))
>     (Node (7,14) (Node (6,12) Tip Tip)
>                  (Node (8,16) Tip Tip))

> find :: Int -> Tree (Int,a) -> Maybe a
> find n Tip = Nothing
> find n (Node (m,d) t1 t2) =
>   if n==m then Just d
>   else if n<m then find n t1
>               else find n t2


> data Peano = Zero | Succ Peano deriving Show

> one   = Succ Zero
> two   = Succ one
> three = Succ two
> four  = Succ three
> five  = Succ four
> six   = Succ five

> data List a = Empty | Cons a (List a)

> decrement :: Peano -> Peano
> decrement Zero = Zero
> decrement (Succ a) = a

> add :: Peano -> Peano -> Peano
> add Zero     b = b
> add (Succ a) b = Succ (add a b)

> sub :: Peano -> Peano -> Peano
> sub a        Zero     = a
> sub Zero     b        = Zero
> sub (Succ a) (Succ b) = sub a b

> equals :: Peano -> Peano -> Bool
> equals Zero     Zero     = True
> equals Zero     b        = False
> equals a        Zero     = False
> equals (Succ a) (Succ b) = equals a b

> lt :: Peano -> Peano -> Bool
> lt a        Zero     = False
> lt Zero     (Succ b) = True
> lt (Succ a) (Succ b) = lt a b

> f_datarec :: a -> [a]
> f_datarec x = x : f_datarec x

> ones = f_datarec 1

> twos = 2 : twos

> object = let a = 1:b
>              b = 2:c
>              c = [3] ++ a
>          in a

-------------------------------------------------------------------------------
			Chapter 8.  Relations
-------------------------------------------------------------------------------


> type Relation a = Set (a,a)

> type Digraph a = (Set a, Relation a)

> domain :: (Eq a, Show a, Eq b, Show b) => Set (a,b) -> Set a
> domain set
>  = if not (normalForm set)
>       then errfun "domain" set "set"
>    else
>    map fst set

> codomain :: (Eq a, Show a, Eq b, Show b) => Set (a,b) -> Set b
> codomain set
>  = if not (normalForm set)
>       then errfun "codomain" set "set"
>    else
>    map snd set

> isDigraph :: (Eq a, Show a) => Digraph a -> Bool
> isDigraph (set, relation)
>  = normalForm set /\ normalForm relation

> digraphEq :: (Eq a, Show a) => Digraph a -> Digraph a -> Bool
> digraphEq digraph1 digraph2
>      = if not (isDigraph digraph1)
>           then errfun "digraphEq" digraph1 "digraph"
>        else
>        if not (isDigraph digraph2)
>           then errfun "digraphEq" digraph2 "digraph"
>        else
>        let (set1,relation1) = digraph1
>            (set2,relation2) = digraph2
>        in (setEq set1 set2) /\ (setEq relation1 relation2)

> isReflexive :: (Eq a, Show a) => Digraph a -> Bool
> isReflexive digraph
>         = if not (isDigraph digraph)
>              then errfun "isReflexive" digraph "digraph"
>           else
>           let (set, relation) = digraph
>           in and [elem (e,e) relation | e <- set]

> isIrreflexive :: (Eq a, Show a) => Digraph a -> Bool
> isIrreflexive digraph
>         = if not (isDigraph digraph)
>              then errfun "isIrreflexive" digraph "digraph"
>           else
>           let (set, relation) = digraph
>           in [a | (a,b) <- relation, a == b && elem a set] == []

> lessThan_N100 :: Digraph Int
> lessThan_N100 
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, a < b])

> equals_N100 :: Digraph Int
> equals_N100
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, a == b])

> greaterThan_N100 :: Digraph Int
> greaterThan_N100
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, a > b])

> lessThanOrEq_N100 :: Digraph Int
> lessThanOrEq_N100
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, a < b \/ a == b])

> greaterThanOrEq_N100 :: Digraph Int
> greaterThanOrEq_N100
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, a > b \/ a == b])

> notEq_N100 :: Digraph Int
> notEq_N100 
>  = let set = [1..100]
>    in (set,[(a,b) | a <- set, b <- set, not (a == b)])

> isSymmetric ::  (Eq a, Show a) => Digraph a -> Bool
> isSymmetric digraph
>      = if not (isDigraph digraph)
>           then errfun "isSymmetric" digraph "digraph"
>        else
>        let (set, relation) = digraph
>        in
>        and [(elem (a,b) relation) ==> (elem (b,a) relation)         
>             | a <- set, b <- set]

> isAntisymmetric ::  (Eq a, Show a) => Digraph a -> Bool
> isAntisymmetric digraph
>      = if not (isDigraph digraph)
>           then errfun "isAntisymmetric" digraph "digraph"
>        else
>        let (set, relation) = digraph
>        in
>        and [((elem (x,y) relation) /\ (elem (y,x) relation))          
>             ==> (x == y) | x <- set, y <- set]

> isTransitive :: (Eq a, Show a) => Digraph a -> Bool
> isTransitive digraph
>      = if not (isDigraph digraph)
>           then errfun "isTransitive" digraph "digraph"
>        else
>        let (set, relation) = digraph
>        in
>        and [((elem (x,y) relation) /\ (elem (y,z) relation))          
>            ==> (elem (x,z) relation)                
>            | x <- set, y <- set, z <- set]

> relationalComposition :: (Show a, Eq b, Show c, Show b, Eq c, Eq a) => 
>                              Set (a,b) -> Set (b,c) -> Set (a,c)
> relationalComposition set1 set2 
>  = if not (normalForm set1)
>       then errfun "relationalComposition" set1 "relation"
>    else
>    if not (normalForm set2)
>       then errfun "relationalComposition" set2 "relation"
>    else
>    normalizeSet [(a,c) | (a,b) <- set1, (b', c) <- set2, b == b']

> equalityRelation :: (Eq a, Show a) => Set a -> Relation a
> equalityRelation set 
>  = if not (normalForm set)
>       then errfun "equalityRelation" set "set"
>    else [(e,e) | e <- set]

> relationalPower :: (Eq a, Show a) => Digraph a -> Int -> Relation a
> relationalPower digraph power
>  = if not (isDigraph digraph)
>       then errfun "relationalPower" digraph "digraph"
>    else
>    relationalPowerLoop digraph power
>    where
>    relationalPowerLoop (set,relation) 0 
>      = equalityRelation set
>    relationalPowerLoop (set,relation) n 
>      = relationalComposition 
>         (relationalPowerLoop (set,relation) (n-1)) relation

> reflexiveClosure :: (Eq a, Show a) => Digraph a -> Digraph a
> reflexiveClosure digraph
>  = if not (isDigraph digraph)
>       then errfun "reflexiveClosure" digraph "digraph"
>    else
>    let (set, relation) = digraph
>    in
>    (set, relation +++ (equalityRelation set))

> inverse :: Set (a,b) -> Set (b,a)
> inverse set = [(b,a) | (a,b) <- set]

> symmetricClosure :: (Eq a, Show a) => Digraph a -> Digraph a
> symmetricClosure digraph
>  = if not (isDigraph digraph)
>       then errfun "symmetricClosure" digraph "digraph"
>    else
>    let (set, relation) = digraph
>    in (set, relation +++ (inverse relation))

> transitiveClosure :: (Eq a, Show a) => Digraph a -> Digraph a
> transitiveClosure digraph
>  = if not (isDigraph digraph)
>       then errfun "transitiveClosure" digraph "digraph"
>    else
>    let (set, relation) = digraph
>        len = length set   
>        loop n power     
>             = if (n > len) 
>                  then []          
>                  else power +++ (loop (n+1) 
>                                  (relationalComposition power relation))
>    in
>    (set, loop 1 relation)   

> isPartialOrder :: (Eq a, Show a) => Digraph a -> Bool
> isPartialOrder digraph
>      = if not (isDigraph digraph)
>           then errfun "isPartialOrder" digraph "digraph"
>        else
>        isReflexive digraph /\
>        (isAntisymmetric digraph /\
>        isTransitive digraph)

> remTransArcs :: (Eq a, Show a) => Relation a -> Relation a
> remTransArcs relation
>  = relation ~~~ [(x,z) | (x,y) <- relation, (y',z) <- relation, y == y']
> 
> remRelArcs ::  (Eq a, Show a) => Relation a -> Relation a
> remRelArcs relation = relation ~~~ [(x,y) | (x,y) <- relation, x == y]
> 
> remReflexTransArcs :: (Eq a, Show a) => Relation a -> Relation a
> remReflexTransArcs relation
>  = remTransArcs (remRelArcs relation)

> isWeakest :: (Eq a, Show a) => Relation a -> a -> Bool
> isWeakest relation a 
>        = if not (normalForm relation)
>             then errfun "isWeakest" relation "relation"
>          else
>          and [a /= c | (b,c) <- remReflexTransArcs relation]

> isGreatest :: (Eq a, Show a) => Relation a -> a -> Bool
> isGreatest set a 
>        = if not (normalForm set)
>             then errfun "isGreatest" set "relation"
>          else
>          and [a /= b | (b,c) <- remReflexTransArcs set]

> weakestSet :: (Eq a, Show a) => Digraph a -> Set a
> weakestSet digraph
>        = if not (isDigraph digraph)
>             then errfun "weakestSet" digraph "digraph"
>          else
>          let (set, relation) = digraph
>          in
>          filter (isWeakest relation) set

> greatestSet :: (Eq a, Show a) => Digraph a -> Set a
> greatestSet digraph
>        = if not (isDigraph digraph)
>             then errfun "greatestSet" digraph "digraph"
>          else
>          let (set,relation) = digraph
>          in
>          filter (isGreatest relation) set

> isQuasiOrder :: (Eq a, Show a) => Digraph a -> Bool
> isQuasiOrder digraph
>      = if not (isDigraph digraph)
>           then errfun "isQuasiOrder" digraph "digraph"
>        else
>        isTransitive digraph /\
>        isIrreflexive digraph

> isChain :: (Eq a, Show a) => Set (a,a) -> Bool
> isChain rel
>  = let loop [] = True
>        loop ((a,b):ps) 
>          = let new_rel = [pr | pr <- rel, not (pr == (a,b))]
>            in
>            if (elem a (codomain new_rel) || elem b (domain new_rel)) 
>               then loop ps
>               else False
>    in loop rel 

> isLinearOrder :: (Eq a, Show a) => Digraph a -> Bool
> isLinearOrder digraph
>      = if not (isDigraph digraph)
>           then errfun "isLinearOrder" digraph "digraph"
>        else if not (isPartialOrder digraph)
>        then errfun "isLinearOrder" digraph "partial order"
>        else
>        let (set,relation) = digraph
>        in
>        isChain (remReflexTransArcs relation)

> removeFromRelation :: (Eq a, Show a) => a -> Set (a,a) -> Set (a,a)
> removeFromRelation elt relation
>      = loop relation
>        where   loop [] = []   
>                loop ((a,b):relation) = if ((elt == a) || (elt == b))        
>                                           then loop relation
>                                           else (a,b) : loop relation

> removeElt :: (Eq a, Show a) => a -> Digraph a -> Digraph a
> removeElt elt (set, relation) 
>      = (set ~~~ [elt],    
>         removeFromRelation elt relation)

> topsort :: (Eq a, Show a) => Digraph a -> Set a
> topsort digraph
>  = if not (isPartialOrder digraph)
>       then errfun "topsort" digraph "partial order"
>    else
>    let topsortLoop ([], relation) = []
>        topsortLoop (set, []) = []
>        topsortLoop digraph
>         = min_elt : topsortLoop (removeElt min_elt digraph)   
>           where   
>           min_elt = head (weakestSet digraph)
>    in topsortLoop digraph

> isEquivalenceRelation :: (Eq a, Show a) => Digraph a -> Bool
> isEquivalenceRelation digraph
>    = if not (isDigraph digraph)
>         then errfun "isEquivalenceRelation" digraph "digraph"
>      else
>      let (set,relation) = digraph
>      in 
>      (isReflexive digraph /\
>        (isSymmetric digraph /\ isTransitive digraph))


-------------------------------------------------------------------------------
			Chapter 9.  Functions
-------------------------------------------------------------------------------

> isFun :: (Eq a, Eq b, Show a, Show b) => 
>              Set a -> Set b -> Set (a,FunVals b) -> Bool
> isFun f_domain f_codomain fun 
>       = let actual_domain = domain fun
>         in normalForm actual_domain /\
>            setEq actual_domain f_domain

> data FunVals a = Undefined | Value a
>                     deriving (Eq, Show)

> isPartialFunction :: (Eq a, Eq b, Show a, Show b) => Set a -> Set b
>                            -> Set (a,FunVals b) -> Bool
> isPartialFunction f_domain f_codomain fun
>      = isFun f_domain f_codomain fun /\
>           elem Undefined (codomain fun)

> imageValues :: (Eq a, Show a) => Set (FunVals a) -> Set a
> imageValues f_codomain
>      = [v | (Value v) <- f_codomain]

> isSurjective :: (Eq a, Eq b, Show a, Show b) => Set a -> 
>                      Set b -> Set (a,FunVals b) -> Bool
> isSurjective f_domain f_codomain fun
>       = isFun f_domain f_codomain fun /\ 
>         setEq f_codomain (normalizeSet (imageValues (codomain fun)))

> isInjective :: (Eq a, Eq b, Show a, Show b) => Set a -> 
>                   Set b -> Set (a,FunVals b) -> Bool
> isInjective f_domain f_codomain fun 
>       = let fun_image = imageValues (codomain fun)
>         in isFun f_domain f_codomain fun /\
>            normalForm fun_image

> functionalComposition :: (Eq a, Eq b, Eq c, Show a, Show b, Show c) => 
>                           Set (a,FunVals b) -> Set (b,FunVals c) -> 
>                              Set (a,FunVals c)
> functionalComposition f1 f2 
>  = normalizeSet [(a,c) | (a,Value b) <- f1, (b', c) <- f2, b == b']

> isBijective :: (Eq a, Eq b, Show a, Show b) => Set a -> Set b
>                     -> Set (a,FunVals b) -> Bool
> isBijective f_domain f_codomain fun 
>       = isSurjective f_domain f_codomain fun /\ 
>         isInjective f_domain f_codomain fun 

> isPermutation
>   :: (Eq a, Show a) => Set a -> Set a -> Set (a,FunVals a) -> Bool
> isPermutation f_domain f_codomain fun 
>       = isBijective f_domain f_codomain fun /\
>         setEq f_domain f_codomain

> diagonal :: Int -> [(Int,Int)] -> [(Int,Int)]
> diagonal stop rest = let interval = [1 .. stop]
>                          in zip interval (reverse interval) ++ rest

> rationals :: [(Int, Int)]
> rationals = foldr diagonal [] [1..]


-------------------------------------------------------------------------------
	 Chapter 10.  Discrete Mathematics in Circuit Design
-------------------------------------------------------------------------------

> class Signal a where
>   inv :: a -> a
>   and2, or2, xor :: a -> a -> a

> instance Signal Bool where
>   inv False = True
>   inv True = False
>   and2 = (&&)
>   or2 = (||)
>   xor False False = False
>   xor False True  = True
>   xor True  False = True
>   xor True  True  = False


> -- halfAdd :: Signal a => a -> a -> (a,a)
> halfAdd a b = (and2 a b, xor a b)

> fullAdd :: Signal a => (a,a) -> a -> (a,a)
> fullAdd (a,b) c = (or2 w y, z)
>   where (w,x) = halfAdd a b
>         (y,z) = halfAdd x c


halfAdd False False
halfAdd False True
halfAdd True  False
halfAdd True  True

fullAdd (False, False) False
fullAdd (False, False) True
fullAdd (False, True)  False
fullAdd (False, True)  True
fullAdd (True,  False) False
fullAdd (True,  False) True
fullAdd (True,  True)  False
fullAdd (True,  True)  True


> add4 :: Signal a => a -> [(a,a)] -> (a,[a])

> add4 c [(x0,y0),(x1,y1),(x2,y2),(x3,y3)] =
>        (c0, [s0,s1,s2,s3])
>   where (c0,s0) = fullAdd (x0,y0) c1
>         (c1,s1) = fullAdd (x1,y1) c2
>         (c2,s2) = fullAdd (x2,y2) c3
>         (c3,s3) = fullAdd (x3,y3) c


    Example: addition of 3 + 8
       3 + 8
       =   0011   (  2+1 =  3)
         + 1000   (    8 =  8)
       =   1011   (8+2+1 = 11)
    Calculate this by evaluating
       add4 False [(False,True),(False,False),(True,False),(True,False)]
    The expected result is
       (False, [True,False,True,True])

> mscanr :: (b->a->(a,c)) -> a -> [b] -> (a,[c])
> mscanr f a [] = (a,[])
> mscanr f a (x:xs) =
>   let (a',ys) = mscanr f a xs
>       (a'',y) = f x a'
>   in (a'', y:ys)

> rippleAdd :: Signal a => a -> [(a,a)] -> (a, [a])
> rippleAdd c zs = mscanr fullAdd c zs

    Example: addition of 23+11
       23 + 11
       =   010111   (16+4+2+1 = 23)
         + 001011   (   8+2+1 = 11) with carry input = 0
       =   100010   (    32+2 = 34) with carry output = 0
    Calculate with the circuit by evaluating
       rippleAdd False [(False,False),(True,False),(False,True),
                      (True,False),(True,True),(True,True)]
    The expected result is
       (False, [True,False,False,False,True,False])