1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
-- https://www.codewars.com/kata/59c132fb70a3b7efd3000024
{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
module ScottEncoding where
import Prelude hiding (null, length, map, foldl, foldr, take, fst, snd, curry, uncurry, concat, zip, (++))
newtype SPair a b = SPair { runPair :: forall c. (a -> b -> c) -> c }
toPair :: SPair a b -> (a,b)
toPair p = (fst p, snd p)
fromPair :: (a,b) -> SPair a b
fromPair (a, b) = SPair $ \f -> f a b
fst :: SPair a b -> a
fst p = runPair p (\a b -> a)
snd :: SPair a b -> b
snd p = runPair p (\a b -> b)
swap :: SPair a b -> SPair b a
swap p = fromPair (b, a) where
a = fst p
b = snd p
curry :: (SPair a b -> c) -> (a -> b -> c)
curry f = \a b -> f $ fromPair (a, b)
uncurry :: (a -> b -> c) -> (SPair a b -> c)
uncurry f = \p -> f (fst p) (snd p)
newtype SMaybe a = SMaybe { runMaybe :: forall b. b -> (a -> b) -> b }
toMaybe :: SMaybe a -> Maybe a
toMaybe sm = runMaybe sm Nothing Just
fromMaybe :: Maybe a -> SMaybe a
fromMaybe m = SMaybe $ case m of
Just x -> \b f -> f x
Nothing -> \b f -> b
isJust :: SMaybe a -> Bool
isJust sm = runMaybe sm False $ const True
isNothing :: SMaybe a -> Bool
isNothing sm = runMaybe sm True $ const False
catMaybes :: SList (SMaybe a) -> SList a
catMaybes slm = go slm $ fromList [] where
go l r =
if null l then sreverse r
else
let x = car l
in
case toMaybe x of
Just x -> go (cdr l) (cons x r)
Nothing -> go (cdr l) r
newtype SEither a b = SEither { runEither :: forall c. (a -> c) -> (b -> c) -> c }
toEither :: SEither a b -> Either a b
toEither se = runEither se Left Right
fromEither :: Either a b -> SEither a b
fromEither e = SEither $ case e of
Left x -> \l r -> l x
Right x -> \l r -> r x
isLeft :: SEither a b -> Bool
isLeft se = runEither se (const True) (const False)
isRight :: SEither a b -> Bool
isRight se = runEither se (const False) (const True)
partition :: SList (SEither a b) -> SPair (SList a) (SList b)
partition sle = go sle (fromList []) (fromList []) where
go sle sll slr =
if null sle then fromPair (sreverse sll, sreverse slr)
else
case toEither (car sle) of
Left x -> go (cdr sle) (cons x sll) slr
Right x -> go (cdr sle) sll (cons x slr)
newtype SList a = SList { runList :: forall b. b -> (a -> SList a -> b) -> b }
toList :: SList a -> [a]
toList sl = runList sl [] (\x xs -> x:toList xs)
fromList :: [a] -> SList a
fromList [] = SList $ \nil _ -> nil
fromList (x:xs) = SList $ \_ f -> f x $ fromList xs
cons :: a -> SList a -> SList a
cons x xs = SList $ \_ f -> f x xs
null :: SList a -> Bool
null sl = runList sl True $ \x xs -> False
car :: SList a -> a
car sl = runList sl (error "cannot car on null list") $ \x xs -> x
cdr :: SList a -> SList a
cdr sl = runList sl (error "cannot car on null list") $ \x xs -> xs
sreverse :: SList a -> SList a
sreverse sl = go sl $ fromList [] where
go l r =
if null l then r
else go (cdr l) (cons (car l) r)
concat :: SList a -> SList a -> SList a
concat sla slb = go (sreverse sla) slb where
go la lb =
if null la then lb
else
go (cdr la) (cons (car la) lb)
length :: SList a -> Int
length sl = go sl 0 where
go sl l =
if null sl then l
else
go (cdr sl) (l+1)
map :: (a -> b) -> SList a -> SList b
map f sl = go sl $ fromList [] where
go sl r =
if null sl then sreverse r
else
go (cdr sl) (cons (f (car sl)) r)
zip :: SList a -> SList b -> SList (SPair a b)
zip sla slb = go sla slb (fromList []) where
go l1 l2 r =
if null l1 || null l2 then sreverse r
else
go (cdr l1) (cdr l2) (cons (fromPair (car l1, car l2)) r)
foldl :: (b -> a -> b) -> b -> SList a -> b
foldl f init sl =
if null sl then init
else
foldl f (f init (car sl)) (cdr sl)
foldr :: (a -> b -> b) -> b -> SList a -> b
foldr f init sl = foldl (flip f) init (sreverse sl)
take :: Int -> SList a -> SList a
take i sl = go i sl $ fromList [] where
go i sl r
| i <= 0 = sreverse r
| null sl = sreverse r
| otherwise = go (i-1) (cdr sl) (cons (car sl) r)
|
