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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
module BinInt where
data Nat = IHi | O Nat | I Nat
succ :: Nat -> Nat
succ IHi = O IHi
succ (O bs) = I bs
succ (I bs) = O (succ bs)
pred :: Nat -> Nat
pred IHi = failed
pred (O IHi) = IHi
pred (O x@(O _)) = I (pred x)
pred (O (I x)) = I (O x)
pred (I x) = O x
(+^) :: Nat -> Nat -> Nat
IHi +^ y = succ y
O x +^ IHi = I x
O x +^ O y = O (x +^ y)
O x +^ I y = I (x +^ y)
I x +^ IHi = O (succ x)
I x +^ O y = I (x +^ y)
I x +^ I y = O (succ x +^ y)
(-^) :: Nat -> Nat -> BinInt
IHi -^ y = inc (Neg y)
x@(O _) -^ IHi = Pos (pred x)
(O x) -^ (O y) = mult2 (x -^ y)
(O x) -^ (I y) = dec (mult2 (x -^ y))
(I x) -^ IHi = Pos (O x)
(I x) -^ (O y) = inc (mult2 (x -^ y))
(I x) -^ (I y) = mult2 (x -^ y)
mult2 :: BinInt -> BinInt
mult2 (Pos n) = Pos (O n)
mult2 Zero = Zero
mult2 (Neg n) = Neg (O n)
(*^) :: Nat -> Nat -> Nat
IHi *^ y = y
(O x) *^ y = O (x *^ y)
(I x) *^ y = y +^ (O (x *^ y))
div2 :: Nat -> Nat
div2 IHi = failed
div2 (O x) = x
div2 (I x) = x
mod2 :: Nat -> BinInt
mod2 IHi = Pos IHi
mod2 (O _) = Zero
mod2 (I _) = Pos IHi
cmpNat :: Nat -> Nat -> Ordering
cmpNat IHi IHi = EQ
cmpNat IHi (O _) = LT
cmpNat IHi (I _) = LT
cmpNat (O _) IHi = GT
cmpNat (O x) (O y) = cmpNat x y
cmpNat (O x) (I y) = case cmpNat x y of
EQ -> LT
cmpxy -> cmpxy
cmpNat (I _) IHi = GT
cmpNat (I x) (O y) = case cmpNat x y of
EQ -> GT
cmpxy -> cmpxy
cmpNat (I x) (I y) = cmpNat x y
quotRemNat :: Nat -> Nat -> (BinInt, BinInt)
quotRemNat x y
| y == IHi = (Pos x, Zero )
| x == IHi = (Zero , Pos IHi)
| otherwise = case cmpNat x y of
EQ -> (Pos IHi, Zero )
LT -> (Zero , Pos x)
GT -> case quotRemNat (div2 x) y of
(Neg _, _ ) -> error "quotRemNat: negative quotient"
(Zero , _ ) -> (Pos IHi , x -^ y)
(Pos _, Neg _) -> error "quotRemNat: negative remainder"
(Pos d, Zero ) -> (Pos (O d), mod2 x)
(Pos d, Pos m) -> case quotRemNat (shift x m) y of
(Neg _ , _ ) -> error "quotRemNat: negative quotient"
(Zero , m') -> (Pos (O d) , m')
(Pos d', m') -> (Pos (O d +^ d'), m')
where
shift IHi _ = error "quotRemNat.shift: IHi"
shift (O _) n = O n
shift (I _) n = I n
data BinInt = Neg Nat | Zero | Pos Nat
lteqInteger :: BinInt -> BinInt -> Bool
lteqInteger x y = cmpInteger x y /= GT
cmpInteger :: BinInt -> BinInt -> Ordering
cmpInteger Zero Zero = EQ
cmpInteger Zero (Pos _) = LT
cmpInteger Zero (Neg _) = GT
cmpInteger (Pos _) Zero = GT
cmpInteger (Pos x) (Pos y) = cmpNat x y
cmpInteger (Pos _) (Neg _) = GT
cmpInteger (Neg _) Zero = LT
cmpInteger (Neg _) (Pos _) = LT
cmpInteger (Neg x) (Neg y) = cmpNat y x
neg :: BinInt -> BinInt
neg Zero = Zero
neg (Pos x) = Neg x
neg (Neg x) = Pos x
inc :: BinInt -> BinInt
inc Zero = Pos IHi
inc (Pos n) = Pos (succ n)
inc (Neg IHi) = Zero
inc (Neg (O n)) = Neg (pred (O n))
inc (Neg (I n)) = Neg (O n)
dec :: BinInt -> BinInt
dec Zero = Neg IHi
dec (Pos IHi) = Zero
dec (Pos (O n)) = Pos (pred (O n))
dec (Pos (I n)) = Pos (O n)
dec (Neg n) = Neg (succ n)
(+#) :: BinInt -> BinInt -> BinInt
Zero +# x = x
x@(Pos _) +# Zero = x
Pos x +# Pos y = Pos (x +^ y)
Pos x +# Neg y = x -^ y
x@(Neg _) +# Zero = x
Neg x +# Pos y = y -^ x
Neg x +# Neg y = Neg (x +^ y)
(-#) :: BinInt -> BinInt -> BinInt
x -# Zero = x
x -# Pos y = x +# Neg y
x -# Neg y = x +# Pos y
(*#) :: BinInt -> BinInt -> BinInt
Zero *# _ = Zero
Pos _ *# Zero = Zero
Pos x *# Pos y = Pos (x *^ y)
Pos x *# Neg y = Neg (x *^ y)
Neg _ *# Zero = Zero
Neg x *# Pos y = Neg (x *^ y)
Neg x *# Neg y = Pos (x *^ y)
quotRemInteger :: BinInt -> BinInt -> (BinInt, BinInt)
quotRemInteger _ Zero = failed
quotRemInteger Zero (Pos _) = (Zero, Zero)
quotRemInteger Zero (Neg _) = (Zero, Zero)
quotRemInteger (Pos x) (Pos y) = quotRemNat x y
quotRemInteger (Neg x) (Pos y) = let (d, m) = quotRemNat x y in (neg d, neg m)
quotRemInteger (Pos x) (Neg y) = let (d, m) = quotRemNat x y in (neg d, m)
quotRemInteger (Neg x) (Neg y) = let (d, m) = quotRemNat x y in (d , neg m)
divModInteger :: BinInt -> BinInt -> (BinInt, BinInt)
divModInteger _ Zero = failed
divModInteger Zero (Pos _) = (Zero, Zero)
divModInteger Zero (Neg _) = (Zero, Zero)
divModInteger (Pos x) (Pos y) = quotRemNat x y
divModInteger (Neg x) (Pos y) = let (d, m) = quotRemNat x y in case m of
Zero -> (neg d, m)
_ -> (neg (inc d), (Pos y) -# m)
divModInteger (Pos x) (Neg y) = let (d, m) = quotRemNat x y in case m of
Zero -> (neg d, m)
_ -> (neg (inc d), m -# (Pos y))
divModInteger (Neg x) (Neg y) = let (d, m) = quotRemNat x y in (d, neg m)
divInteger :: BinInt -> BinInt -> BinInt
divInteger x y = fst (divModInteger x y)
modInteger :: BinInt -> BinInt -> BinInt
modInteger x y = snd (divModInteger x y)
quotInteger :: BinInt -> BinInt -> BinInt
quotInteger x y = fst (quotRemInteger x y)
remInteger :: BinInt -> BinInt -> BinInt
remInteger x y = snd (quotRemInteger x y)
|