Main.hs

module Main where

import Prelude ((++), putStrLn)

data Unit = Unit

data TrueFalse = True | False

data List a = Nil | Cons a (List a)

data Ord = LT | EQ | GT

data PositiveWholeNumber = Zero | Succ PositiveWholeNumber

one :: PositiveWholeNumber
one = Succ Zero

two :: PositiveWholeNumber
two = Succ one

three :: PositiveWholeNumber
three = Succ two

four :: PositiveWholeNumber
four = Succ three

const :: a -> b -> a
const x y = x

eq :: PositiveWholeNumber -> PositiveWholeNumber -> TrueFalse
eq Zero Zero = True
eq Zero (Succ y) = False
eq (Succ x) Zero = False
eq (Succ x) (Succ y) = eq x y

compare :: PositiveWholeNumber -> PositiveWholeNumber -> Ord
compare Zero Zero = EQ
compare Zero (Succ y) = LT
compare (Succ x) Zero = GT
compare (Succ x) (Succ y) = compare x y

append :: List a -> List a -> List a
append Nil ys = ys
append (Cons x xs) ys = Cons x (append xs ys)

bind :: List a -> (a -> List b) -> List b
bind Nil f = Nil
bind (Cons x xs) f = append (f x) (bind xs f)

empty :: List a
empty = Nil

pure :: a -> List a
pure x = Cons x Nil

guard :: TrueFalse -> List Unit
guard True = pure Unit
guard False = empty

minus :: PositiveWholeNumber -> PositiveWholeNumber -> PositiveWholeNumber
minus Zero y = Zero
minus x Zero = x
minus (Succ x) (Succ y) = minus x y

decrement :: PositiveWholeNumber -> PositiveWholeNumber
decrement Zero = Zero
decrement (Succ x) = x

mod :: PositiveWholeNumber -> PositiveWholeNumber -> PositiveWholeNumber
mod x Zero = Zero
mod Zero y = Zero
mod x (Succ Zero) = Zero
mod x y =
  ord
    x
    (mod (minus x y) y)
    (mod (minus x y) y)
    (compare x y)

ord :: a -> a -> a -> Ord -> a
ord x y z LT = x
ord x y z EQ = y
ord x y z GT = z

range :: PositiveWholeNumber -> PositiveWholeNumber -> List PositiveWholeNumber
range x y = range' Nil x y

range' :: List PositiveWholeNumber -> PositiveWholeNumber -> PositiveWholeNumber -> List PositiveWholeNumber
range' acc x y =
  ord
    (range' (Cons y acc) x (decrement y))
    (Cons y acc)
    (range' (Cons y acc) x (Succ y))
    (compare x y)

twoToFour :: List PositiveWholeNumber
twoToFour = range two four

fourToTwo :: List PositiveWholeNumber
fourToTwo = range four two

guardDividesEvenly :: PositiveWholeNumber -> PositiveWholeNumber -> List Unit
guardDividesEvenly x y = guard (eq (mod x y) Zero)

pureSecondArgumentIfDividesEvenly :: PositiveWholeNumber -> PositiveWholeNumber -> List PositiveWholeNumber
pureSecondArgumentIfDividesEvenly x y =
  bind (guardDividesEvenly x y) (const (pure y))

factors :: PositiveWholeNumber -> List PositiveWholeNumber
factors x = Cons one (bind (range two x) (pureSecondArgumentIfDividesEvenly x))

main = putStrLn (printList printPositiveWholeNumber (factors four))

-- The following is a really basic way of turning Lists and PositiveWholeNumbers into text

printList print x = printList' False print x

printList' False print Nil = "[]"
printList' False print (Cons x Nil) = "[" ++ print x ++ "]"
printList' False print (Cons x xs) = "[" ++ print x ++ ", " ++ printList' True print xs ++ "]"
printList' True print Nil = ""
printList' True print (Cons x Nil) = print x
printList' True print (Cons x xs) = print x ++ ", " ++ printList' True print xs

printPositiveWholeNumber x = printPositiveWholeNumber' False x

printPositiveWholeNumber' False Zero = "0"
printPositiveWholeNumber' True Zero = ""
printPositiveWholeNumber' _ (Succ x) = printPositiveWholeNumber' True x ++ "I"

WorkedExamples.hs

range two four = range' Nil two four
range two four =
  ord
    (range (Cons four Nil) two (decrement four))
    (Cons four acc)
    (range (Cons four acc) two (Succ four))
    (compare two four)
range two four = range' (Cons four Nil) two (decrement four)
range two four = range' (Cons four Nil) two three
range two four =
  ord
    (range' (Cons three (Cons four Nil)) two (decrement three))
    (Cons three (Cons four Nil))
    (range' (Cons three (Cons four Nil)) two (Succ three))
    (compare two three)
range two four = range' (Cons three (Cons four Nil)) two (decrement three)
range two four = range' (Cons three (Cons four Nil)) two two
  ord
    (range' (Cons two (Cons three (Cons four Nil))) two (decrement two))
    (Cons two (Cons three (Cons four Nil)))
    (range' (Cons two (Cons three (Cons four Nil))) two (Succ two))
    (compare two two)
range two four = Cons two (Cons three (Cons four Nil))

range four two = range' Nil four two
range four two =
  ord
    (range' (Cons two Nil) four (decrement two)
    (Cons two Nil)
    (range' (Cons two Nil) four (Succ two))
    (compare four two)
range four two = range' (Cons two Nil) four (Succ two)
range four two = range' (Cons two Nil) four three
range four two =
  ord
    (range' (Cons three (Cons two Nil)) four (decrement three)
    (Cons three (Cons two Nil))
    (range' (Cons three (Cons two Nil)) four (Succ three))
    (compare four three)
range four two = range' (Cons three (Cons two Nil)) four (Succ three)
range four two = range' (Cons three (Cons two Nil)) four four
range four two =
  ord
    (range' (Cons four (Cons three (Cons two Nil))) four (decrement four)
    (Cons four (Cons three (Cons two Nil)))
    (range' (Cons four (Cons three (Cons two Nil))) four (Succ four))
    (compare four four)
range four two = Cons four (Cons three (Cons two Nil))