diff --git a/app/Main.hs b/app/Main.hs index de1c1ab..1623b4b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,10 @@ module Main where -import Lib +import Base +import ChurchBool +import ChurchNum +import Lib +import Tuple main :: IO () main = someFunc diff --git a/src/Base.hs b/src/Base.hs new file mode 100644 index 0000000..4f0bbc5 --- /dev/null +++ b/src/Base.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Base ( + identity, + constant, + apply, + compose, + flip +) where + +-- | Identity function. +-- id :: a -> a +-- identity = \x -> x +identity x = x + +-- | Constant function. +-- const :: a -> b -> a +-- constant = \x y -> x +constant x y = x + +-- apply :: (t1 -> t2) -> t1 -> t2 +-- apply = \f x -> f x +apply f x = f x + +-- compose :: (t1 -> t2) -> (t3 -> t1) -> t3 -> t2 +-- compose = \x y z -> x ( y (z)) +compose x y z = x ( y ( z ) ) + +-- flip :: (a -> b -> c) -> b -> a -> c +-- flip = \f x y -> f y x +flip f x y = f y x diff --git a/src/ChurchBool.hs b/src/ChurchBool.hs new file mode 100644 index 0000000..2a7409e --- /dev/null +++ b/src/ChurchBool.hs @@ -0,0 +1,31 @@ +module ChurchBool where +import Base +import ChurchNum + +-- true :: p1 -> p2 -> p1 +true a b = a + +-- false :: p1 -> p2 -> p2 +false a b = b + +-- cond :: (t1 -> t2 -> t3) -> t1 -> t2 -> t3 +-- cond = identity +cond a b c = a b c + +-- ((p2 -> p1 -> p3 -> p3) -> (p4 -> p5 -> p4) -> t) -> t +isZero n = n (Base.constant false) true + +-- toNum :: (((t1 -> t2) -> t1 -> t2) -> (p2 -> t3 -> t3) -> t) -> t +toChurchNum x = x one zero +-- unchurch $ toChurchNum $ ChurchBool.isZero zero + +-- (t1 -> (p1 -> p2 -> p2) -> t2) + -- -> ((p3 -> p4 -> p3) -> (p5 -> p6 -> p6) -> t1) -> t2 +and' a b = cond a (cond b true false) false + +-- ((p1 -> p2 -> p1) -> t1 -> t2) +-- -> ((p3 -> p4 -> p3) -> (p5 -> p6 -> p6) -> t1) -> t2 +or' a b = cond a true (cond b true false) + +-- not' :: ((p1 -> p2 -> p2) -> (p3 -> p4 -> p3) -> t) -> t +not' a = cond a false true diff --git a/src/ChurchNum.hs b/src/ChurchNum.hs new file mode 100644 index 0000000..5e3bd62 --- /dev/null +++ b/src/ChurchNum.hs @@ -0,0 +1,53 @@ +module ChurchNum ( + zero, -- point free + one, -- point free + two, -- point free + inc, -- point free + dec , + add, + sub, + mul, -- point free + church, + unchurch,-- point free + isZero +) where + +import Base +import Combinators + +-- zero :: p2 -> t3 -> t3 +zero = Base.flip Base.constant + +-- one :: (t1 -> t2) -> t1 -> t2 +one = apply + +-- two :: (t -> t) -> t -> t +-- @help: can't figure out point free version (cause s-combinator is not) +-- two x y = x $ x y +two = s Base.compose Base.identity + +-- inc :: Num a => a -> a +inc = (+1) + +-- dec :: Num a => a -> a +-- dec x = x - 1 +dec = Base.flip (-) 1 + +-- add :: Num a => a -> a -> a +add = (+) + +-- sub :: Num a => a -> a -> a +sub = (-) + +-- mult :: Num a => a -> a -> a +mul a b = church a (+b) 0 + +-- church :: (Eq t1, Num t1) => t1 -> (t2 -> t2) -> t2 -> t2 +church 0 = zero +church n = \f x -> f $ church (n -1 ) f x + +-- unchurch :: ((Integer -> Integer) -> Integer -> t3) -> t3 +unchurch = Base.flip ($ (1 +)) 0 + +-- isZero :: (Eq a, Num a) => a -> Bool +isZero = (==) 0 diff --git a/src/Combinators.hs b/src/Combinators.hs new file mode 100644 index 0000000..88490ff --- /dev/null +++ b/src/Combinators.hs @@ -0,0 +1,5 @@ +module Combinators where + +s f g x = f x (g x) -- S-combinator +identity x = x -- I-combinator +constant x y = y -- K -combinator diff --git a/src/Tuple.hs b/src/Tuple.hs new file mode 100644 index 0000000..af2a810 --- /dev/null +++ b/src/Tuple.hs @@ -0,0 +1,24 @@ +module Tuple where + +import Base + +constant' = Base.constant +flip' = Base.flip + +-- tuple' :: t1 -> t2 -> (t1 -> t2 -> t3) -> t3 +tuple' a b f = f a b + +-- first' :: ((p1 -> p2 -> p1) -> b) -> b +first' = ($ constant') + +-- second' :: ((p2 -> t3 -> t3) -> t) -> t +second' t = t $ flip' constant' + +-- swap' :: ((p2 -> p2 -> p2) -> t1) -> (t1 -> t1 -> t2) -> t2 +swap' t = tuple' (second' t) (first' t) + +-- curry' :: (((t1 -> t2 -> t3) -> t3) -> t4) -> t1 -> t2 -> t4 +curry' f = f $ tuple' + +-- t1 -> (t1 -> t2) -> t2 +uncurry' f t = t f