{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
module Data.Typical where
import Data.Typical.Misc
-- the HCons and HNil datatype
--
data a :#: b = a :#: b
infixr :#:
data HNil = HNil
-- basic list operations
class HHead a h | a -> h where
hHead :: a -> h
instance HHead (a :#: b) a where
hHead (a :#: _) = a
class HTail a t | a -> t where
hTail :: a -> t
instance HTail (a :#: b) b where
hTail (_ :#: b) = b
class HSplitAt a n h t | a n -> h t where
hSplitAt :: a -> n -> (h, t)
instance HSplitAt HNil n HNil HNil where
hSplitAt HNil _ = (HNil, HNil)
instance HSplitAt (a :#: b) HNil (a :#: HNil) b where
hSplitAt (a :#: b) HNil = (a :#: HNil, b)
instance (HSub (d :#: d') HNil predD, HSplitAt b predD a' b')
=> HSplitAt (a :#: b) (d :#: d') (a :#: a') b' where
hSplitAt (a :#: b) d = let (a', b') = hSplitAt b (hSub d HNil) in (a :#: a' , b')
class HMergeBy f a b c | f a b -> c where
hMergeBy :: f -> a -> b -> c
instance HMergeBy f HNil HNil HNil where
hMergeBy _ HNil HNil = HNil
instance HMergeBy f HNil (a :#: b) (a :#: b) where
hMergeBy _ HNil (a :#: b) = a :#: b
instance HMergeBy f (a :#: b) HNil (a :#: b) where
hMergeBy _ (a :#: b) HNil = a :#: b
instance (HApply f (a, c) cmp, HOrd cmp (a :#: b) (c :#: d) h a' b', HMergeBy f a' b' e)
=> HMergeBy f (a :#: b) (c :#: d) (h :#: e) where
hMergeBy f (a :#: b) (c :#: d) = let
cmp = hApply f (a, c)
(h, a', b') = hOrd cmp (a :#: b) (c :#: d)
e = hMergeBy f a' b'
in (h :#: e)
{-
class HSortBy f a b | f a -> b where
hSortBy :: f -> a -> b
class HRunsBy f cmp a tmp tmp' res | f cmp a tmp -> tmp' res where
hRunsBy :: f -> cmp -> a -> tmp -> (tmp', res)
instance (HRunsBy f cmp (b :#: c :#: d) tmp tmp' res, HApply f (b, c) cmp)
=> HRunsBy f HLT (a :#: b :#: c :#: d) tmp (a :#: tmp', res)
instance (HRunsBy f cmp (b :#: c :#: d) tmp tmp' res, HApply f (b, c) cmp)
=> HRunsBy f HEQ (a :#: b :#: c :#: d) tmp (a :#: tmp', res)
instance (HRunsBy f cmp (b :#: c :#: d) tmp tmp' res, HApply f (b, c) cmp)
=> HRunsBy f HGT (a :#: b :#: c :#: d) tmp (a :#: HNil, tmp :#: res)
-}
-- the apply class for function objects
--
class HApply f parameter result | f parameter -> result where
hApply :: f -> parameter -> result
-- the atoms of numbers (binary digits)
--
data B0 = B0
data B1 = B1
-- the class of natural numbers
class HNat a
instance HNat (B1 :#: HNil)
instance HNat a => HNat (B1 :#: a)
instance HNat a => HNat (B0 :#: a)
type N1 = HNil
type N2 = B0 :#: HNil
type N3 = B1 :#: HNil
type N4 = B0 :#: N2
n1 :: N1
n1 = HNil
n2 :: N2
n2 = B0 :#: HNil
n3 :: N3
n3 = B1 :#: HNil
n4 :: N4
n4 = B0 :#: n2
-- addition
class HAdd n1 n2 r | n1 n2 -> r where
hAdd :: n1 -> n2 -> r
instance HAdd HNil HNil (B0 :#: HNil) where
hAdd HNil HNil = (B0 :#: HNil)
instance HAdd HNil (B0 :#: b) (B1 :#: b) where
hAdd HNil (B0 :#: b) = B1 :#: b
instance HAdd (B0 :#: a) HNil (B1 :#: a) where
hAdd (B0 :#: a) HNil = B1 :#: a
instance HAdd HNil b b' => HAdd HNil (B1 :#: b) (B0 :#: b') where
hAdd HNil (B1 :#: b) = B0 :#: hAdd HNil b
instance HAdd HNil a a' => HAdd (B1 :#: a) HNil (B0 :#: a') where
hAdd (B1 :#: a) HNil = B0 :#: hAdd HNil a
instance HAdd a b c => HAdd (B0 :#: a) (B0 :#: b) (B0 :#: c) where
hAdd (B0 :#: a) (B0 :#: b) = B0 :#: hAdd a b
instance HAdd a b c => HAdd (B0 :#: a) (B1 :#: b) (B1 :#: c) where
hAdd (B0 :#: a) (B1 :#: b) = B1 :#: hAdd a b
instance HAdd a b c => HAdd (B1 :#: a) (B0 :#: b) (B1 :#: c) where
hAdd (B1 :#: a) (B0 :#: b) = B1 :#: hAdd a b
instance (HAdd a b c, HAdd HNil c c') => HAdd (B1 :#: a) (B1 :#: b) (B0 :#: c') where
hAdd (B1 :#: a) (B1 :#: b) = B0 :#: hAdd HNil (hAdd a b)
-- substraction
--
class HSub n1 n2 r | n1 n2 -> r where
hSub :: n1 -> n2 -> r
instance HSub (B1 :#: b) HNil (B0 :#: b) where
hSub (B1 :#: b) HNil = B0 :#: b
instance HSub (B0 :#: HNil) HNil HNil where
hSub (B0 :#: HNil) HNil = HNil
instance HSub (B1 :#: HNil) (B0 :#: HNil) HNil where
hSub (B1 :#: HNil) (B0 :#: HNil) = HNil
instance HSub (b :#: c) HNil d => HSub (B0 :#: b :#: c) HNil (B1 :#: d) where
hSub (B0 :#: b :#: c) HNil = B1 :#: hSub (b :#: c) HNil
instance HSub a b c => HSub (B0 :#: a) (B0 :#: b) (B0 :#: c) where
hSub (B0 :#: a) (B0 :#: b) = B0 :#: hSub a b
instance HSub (a :#: b) c d => HSub (B1 :#: a :#: b) (B0 :#: c) (B1 :#: d) where
hSub (B1 :#: a :#: b) (B0 :#: c) = B1 :#: hSub (a :#: b) c
instance (HAdd b N1 b', HSub a b' c) => HSub (B0 :#: a) (B1 :#: b) (B1 :#: c) where
hSub (B0 :#: a) (B1 :#: b) = B1 :#: hSub a (hAdd b HNil)
instance HSub a b c => HSub (B1 :#: a) (B1 :#: b) (B0 :#: c) where
hSub (B1 :#: a) (B1 :#: b) = B0 :#: hSub a b
-- multiplication
--
class HMul a b c | a b -> c where
hMul :: a -> b -> c
class HMulSub a b c | a b -> c where
hMulSub :: a -> b -> c
instance HMulSub HNil a (a :#: HNil) where
hMulSub HNil a = (a :#: HNil)
instance HMulSub b (B0 :#: c) r => HMulSub (B0 :#: b) c r where
hMulSub (B0 :#: b) c = hMulSub b (B0 :#: c)
instance HMulSub b (B0 :#: c) r => HMulSub (B1 :#: b) c (c :#: r) where
hMulSub (B1 :#: b) c = let r = hMulSub b (B0 :#: c) in (c :#: r)
-- comparism
instance HCompare B0 B0 HEQ where
hCompare B0 B0 = HEQ
instance HCompare B0 B1 HLT where
hCompare B0 B1 = HLT
instance HCompare B1 B0 HGT where
hCompare B1 B0 = HGT
instance HCompare B1 B1 HEQ where
hCompare B1 B1 = HEQ
instance HCompare HNil HNil HEQ where
hCompare HNil HNil = HEQ
instance HCompare HNil (c :#: d) HLT where
hCompare HNil (_ :#: _) = HLT
instance HCompare (a :#: b) HNil HGT where
hCompare (_ :#: _) HNil = HGT
instance (HCompare a c res1, HCompare b d res2, CalcRes res1 res2 res)
=> HCompare (a :#: b) (c :#: d) res where
hCompare (a :#: b) (c :#: d) = calcRes (hCompare a c) (hCompare b d)
class CalcRes a b c | a b -> c where
calcRes :: a -> b -> c
instance CalcRes a HLT HLT where
calcRes _ HLT = HLT
instance CalcRes a HGT HGT where
calcRes _ HGT = HGT
instance CalcRes HLT HEQ HLT where
calcRes HLT HEQ = HLT
instance CalcRes HGT HEQ HGT where
calcRes HGT HEQ = HGT
instance CalcRes HEQ HEQ HEQ where
calcRes HEQ HEQ = HEQ
class HOrd cmp a b h a' b' | cmp a b -> h a' b' where
hOrd :: cmp -> a -> b -> (h, a', b')
instance HOrd HLT (ha :#: ta) (hb :#: tb) ha ta (hb :#: tb) where
hOrd HLT (ha :#: ta) (hb :#: tb) = (ha, ta, hb :#: tb)
instance HOrd HGT (ha :#: ta) (hb :#: tb) hb (ha :#: ta) tb where
hOrd HGT (ha :#: ta) (hb :#: tb) = (hb, ha :#: ta, tb)
instance HOrd HEQ (ha :#: ta) (hb :#: tb) ha ta (hb :#: tb) where
hOrd HEQ (ha :#: ta) (hb :#: tb) = (ha, ta, hb :#: tb)
-- simple math
--
class HDiv2 a b | a -> b where
hDiv2 :: a -> b
instance HDiv2 HNil HNil where
hDiv2 HNil = HNil
instance HDiv2 (a :#: b) b where
hDiv2 (_ :#: b) = b
-- tests
--
--
data HCmpHNat = HCmpHNat
instance HCompare a b cmp => HApply HCmpHNat (a, b) cmp where
hApply HCmpHNat (a, b) = hCompare a b
x :: (N2 :#: N2 :#: N3 :#: N4 :#: HNil)
x = hMergeBy HCmpHNat (n2 :#: n3 :#: HNil) ((n4 `hSub` n2) :#: n4 :#: HNil)