The Semantic Elegance of Applicative Languages

paraffin.hs

import Data.List

data Atom = Hydrogen | Carbon Atom Atom Atom
type Paraffin = (Atom, Atom, Atom, Atom)

instance Show Atom where
  show (Hydrogen) = "H"
  show (Carbon a1 a2 a3) = "C[" ++ show a1 ++ "," ++ show a2 ++ "," ++ show a3 ++ "]"

instance Eq Atom where
  Hydrogen == Hydrogen = True
  (Carbon a1 a2 a3) == (Carbon a4 a5 a6) = and [a1==a4,a2==a5,a3==a6] 
  a1 == a2 = False

invert :: Paraffin -> Paraffin 
invert  ((Carbon a1 a2 a3), Hydrogen, Hydrogen, Hydrogen)  = 
  	  (Hydrogen, Hydrogen, Hydrogen, (Carbon a2 a2 a3))
invert (Hydrogen,a2,a3,a4) = (Hydrogen,a2,a3,a4)

rotate :: Paraffin -> Paraffin
rotate (a1,a2,a3,a4) = (a2,a3,a4,a1)

swap :: Paraffin -> Paraffin
swap (a1,a2,a3,a4) = (a2,a1,a3,a4)

equiv :: Paraffin -> Paraffin -> Bool
equiv x y = elem y (equivclass x)

equivclass :: Paraffin -> [Paraffin]
equivclass x = closure_under_laws [rotate,invert,swap] [x]

closure_under_laws :: [(Paraffin -> Paraffin)] -> [Paraffin] -> [Paraffin]
closure_under_laws fs ps  = ps ++ closure' fs ps ps

closure' :: [(Paraffin -> Paraffin)] -> [Paraffin] -> [Paraffin] -> [Paraffin]
closure' fs ps ts = closure'' fs ps
                   (nub [x | f <- fs, x <- map f ts, not (elem x ps)])


closure'' :: [(Paraffin -> Paraffin)] -> [Paraffin] -> [Paraffin] -> [Paraffin]
closure'' fs ps [] = []
closure'' fs ps ts = ts ++ closure' fs (ps ++ ts) ts 


-- all paraffin molecules with n carbons
paraffin :: Int -> [Paraffin]
paraffin n = quotient equiv [(x,Hydrogen,Hydrogen,Hydrogen) | x <- memoised_para(n-1)]

quotient :: (Paraffin -> Paraffin -> Bool) -> [Paraffin] -> [Paraffin]
quotient f [] = []
quotient f (p:ps) = p:qs where
	            qs = [ q | q <- quotient f ps, not (f p q)]

para :: Int -> [Atom]
para 0 = [Hydrogen]
para n = [(Carbon x y z) | i <- [0..(n-1) `div` 3], j <- [i..(n-1-i) `div` 2], 
	          x <- para i, y <- para j, z <- para (n-1-i-j)] 

memoised_para :: Int -> [Atom]
memoised_para = (map para [0..] !!)

paraffins = concat (map paraffin [1..])