-
Notifications
You must be signed in to change notification settings - Fork 2
/
Prelude.fs
348 lines (258 loc) · 17.9 KB
/
Prelude.fs
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
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
module Prelude
let flip f x y = f y x
let const' k _ = k
let (</) = (|>)
let (/>) = flip
let (++) = (@)
let (==) = (=)
let (=/) x y = not (x = y)
type DeReference = DeReference with
static member instance (DeReference, a:'a ref , _) = fun () -> !a
static member instance (DeReference, a:string , _) = fun () -> a.ToCharArray() |> Array.toList
static member instance (DeReference, a:DeReference, _) = fun () -> DeReference
let inline (!) a = Inline.instance (DeReference, a) ()
type Maybe<'t> = Option<'t>
let Just x :Maybe<'t> = Some x
let Nothing:Maybe<'t> = None
let (|Just|Nothing|) = function Some x -> Just x | _ -> Nothing
let maybe n f = function | Nothing -> n | Just x -> f x
type Ordering = LT|EQ|GT
let inline compare' x y =
match compare x y with
| a when a > 0 -> GT
| a when a < 0 -> LT
| _ -> EQ
type Either<'a,'b> = Left of 'a | Right of 'b
let either f g = function Left x -> f x | Right y -> g y
// Num class --------------------------------------------------------------
open System.Numerics
type Integer = bigint
type FromInteger = FromInteger with
static member instance (_Num:FromInteger, _:sbyte ) = fun (x:Integer) -> sbyte x
static member instance (_Num:FromInteger, _:int16 ) = fun (x:Integer) -> int16 x
static member instance (_Num:FromInteger, _:int32 ) = fun (x:Integer) -> int x
static member instance (_Num:FromInteger, _:int64 ) = fun (x:Integer) -> int64 x
static member instance (_Num:FromInteger, _:nativeint ) = fun (x:Integer) -> nativeint (int x)
static member instance (_Num:FromInteger, _:byte ) = fun (x:Integer) -> byte x
static member instance (_Num:FromInteger, _:uint16 ) = fun (x:Integer) -> uint16 x
static member instance (_Num:FromInteger, _:uint32 ) = fun (x:Integer) -> uint32 x
static member instance (_Num:FromInteger, _:uint64 ) = fun (x:Integer) -> uint64 x
static member instance (_Num:FromInteger, _:unativeint) = fun (x:Integer) -> unativeint (int x)
static member instance (_Num:FromInteger, _:bigint ) = fun (x:Integer) -> x
static member instance (_Num:FromInteger, _:float ) = fun (x:Integer) -> float x
static member instance (_Num:FromInteger, _:float32 ) = fun (x:Integer) -> float32 x
static member instance (_Num:FromInteger, _:decimal ) = fun (x:Integer) -> decimal x
static member instance (_Num:FromInteger, _:Complex ) = fun (x:Integer) -> Complex (float x, 0.0)
let inline fromInteger (x:Integer) :'Num = Inline.instance FromInteger x
type Abs = Abs with
static member inline instance ( Abs, _:^t when ^t: null and ^t: struct, _) = fun () -> id
static member inline instance (_Num:Abs, x:'t , _) = fun () -> abs x
static member instance (_Num:Abs, x:byte , _) = fun () -> x
static member instance (_Num:Abs, x:uint16 , _) = fun () -> x
static member instance (_Num:Abs, x:uint32 , _) = fun () -> x
static member instance (_Num:Abs, x:uint64 , _) = fun () -> x
static member instance (_Num:Abs, x:unativeint, _) = fun () -> x
static member instance (_Num:Abs, x:Complex , _) = fun () -> Complex(x.Magnitude, 0.0)
let inline abs (x:'Num) :'Num = Inline.instance (Abs, x) ()
type Signum = Signum with
static member inline instance ( Signum, _:^t when ^t: null and ^t: struct, _) = fun () -> id
static member inline instance (_Num:Signum, x:'t , _) = fun () -> fromInteger (bigint (sign x)) :'t
static member instance (_Num:Signum, x:byte , _) = fun () -> if x == 0uy then 0uy else 1uy
static member instance (_Num:Signum, x:uint16 , _) = fun () -> if x == 0us then 0us else 1us
static member instance (_Num:Signum, x:uint32 , _) = fun () -> if x == 0u then 0u else 1u
static member instance (_Num:Signum, x:uint64 , _) = fun () -> if x == 0UL then 0UL else 1UL
static member instance (_Num:Signum, x:unativeint, _) = fun () -> if x == 0un then 0un else 1un
static member instance (_Num:Signum, x:Complex , _) = fun () ->
if x.Magnitude == 0.0 then Complex.Zero
else Complex(x.Real / x.Magnitude, x.Imaginary / x.Magnitude)
let inline signum (x:'Num) :'Num = Inline.instance (Signum, x) ()
let inline (+) (a:'Num) (b:'Num) :'Num = a + b
let inline (-) (a:'Num) (b:'Num) :'Num = a - b
let inline (*) (a:'Num) (b:'Num) :'Num = a * b
type Negate = Negate with
static member inline instance ( Negate, _:^t when ^t: null and ^t: struct, _) = fun () -> id
static member inline instance (_Num:Negate, x:'t , _) = fun () -> -x
static member instance (_Num:Negate, x:byte , _) = fun () -> 0uy - x
static member instance (_Num:Negate, x:uint16 , _) = fun () -> 0us - x
static member instance (_Num:Negate, x:uint32 , _) = fun () -> 0u - x
static member instance (_Num:Negate, x:uint64 , _) = fun () -> 0UL - x
static member instance (_Num:Negate, x:unativeint, _) = fun () -> 0un - x
let inline negate (x:'Num) :'Num = Inline.instance (Negate, x) ()
let inline (~-) (x:'Num) :'Num = Inline.instance (Negate, x) ()
// Integral class ---------------------------------------------------------
type ToInteger = ToInteger with
static member instance (_Integral:ToInteger, x:sbyte , _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:int16 , _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:int32 , _) = fun () -> bigint x
static member instance (_Integral:ToInteger, x:int64 , _) = fun () -> bigint x
static member instance (_Integral:ToInteger, x:nativeint , _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:byte , _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:uint16 , _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:uint32 , _) = fun () -> bigint x
static member instance (_Integral:ToInteger, x:uint64 , _) = fun () -> bigint x
static member instance (_Integral:ToInteger, x:unativeint, _) = fun () -> bigint (int x)
static member instance (_Integral:ToInteger, x:bigint , _) = fun () -> x
let inline toInteger (x:'Integral) :Integer = Inline.instance (ToInteger, x) ()
let inline fromIntegral (x:'Integral) :'Num = (fromInteger << toInteger) x
module NumericLiteralG =
let inline FromZero() = fromIntegral 0
let inline FromOne () = fromIntegral 1
let inline FromInt32 (i:int ) = fromIntegral i
let inline FromInt64 (i:int64 ) = fromIntegral i
let inline FromString (i:string) = fromInteger <| BigInteger.Parse i
let inline whenIntegral a = let _ = if false then toInteger a else 0I in ()
let inline quot (a:'Integral) (b:'Integral) :'Integral = whenIntegral a; a / b
let inline rem (a:'Integral) (b:'Integral) :'Integral = whenIntegral a; a % b
let inline quotRem a b :'Integral * 'Integral = (quot a b, rem a b)
let inline div (a:'Integral) b :'Integral =
whenIntegral a
let (a,b) = if b < 0G then (-a,-b) else (a,b)
(if a < 0G then (a - b + 1G) else a) / b
let inline mod' a b :'Integral = whenIntegral a; ((a % b) + b) % b
let inline divMod a b :'Integral * 'Integral = (div a b, mod' a b)
// Numeric Functions ------------------------------------------------------
let inline gcd x y :'Integral =
let zero = 0G
let rec gcd' a = function
| b when b = zero -> a
| b -> gcd' b (a </rem/> b)
match(x,y) with
| t when t = (zero,zero) -> failwith "Prelude.gcd: gcd 0 0 is undefined"
| _ -> gcd' (abs x) (abs y)
// Ratio ------------------------------------------------------------------
module Ratio =
type Ratio<'Integral> = Ratio of 'Integral * 'Integral with
override this.ToString() =
let (Ratio(n,d)) = this
n.ToString() + " % " + d.ToString()
let inline (%) (a:'Integral) (b:'Integral) :Ratio<'Integral> =
whenIntegral a
let zero = 0G
if b == zero then failwith "Ratio.%: zero denominator"
let (a,b) = if b < zero then (negate a, negate b) else (a, b)
let gcd = gcd a b
Ratio (a </quot/> gcd, b </quot/> gcd)
let inline Ratio (x,y) = x % y
let numerator (Ratio(x,_)) = x
let denominator (Ratio(_,x)) = x
type Ratio<'Integral> with
static member inline (/) (Ratio(a,b), Ratio(c,d)) = (a * d) % (b * c)
static member inline (+) (Ratio(a,b), Ratio(c,d)) = (a * d + c * b) % (b * d)
static member inline (-) (Ratio(a,b), Ratio(c,d)) = (a * d - c * b) % (b * d)
static member inline (*) (Ratio(a,b), Ratio(c,d)) = (a * c) % (b * d)
open Ratio
type Rational = Ratio<Integer>
let inline (%) (a:'Integral) (b:'Integral) :Ratio<'Integral> = a % b
type Abs with static member inline instance (_Num:Abs , r:Ratio<_>, _) = fun () -> (abs (numerator r)) % (denominator r)
type Signum with static member inline instance (_Num:Signum , r:Ratio<_>, _) = fun () -> (signum (numerator r)) % 1G
type FromInteger with static member inline instance (_Num:FromInteger, _:Ratio<_> ) = fun (x:Integer) -> fromInteger x % 1G
type Negate with static member inline instance (_Num:Negate , r:Ratio<_>, _) = fun () -> -(numerator r) % (denominator r)
// Fractional class -------------------------------------------------------
type FromRational = FromRational with
static member instance (_Fractional:FromRational, _:float ) = fun (r:Rational) -> float (numerator r) / float (denominator r)
static member instance (_Fractional:FromRational, _:float32 ) = fun (r:Rational) -> float32 (numerator r) / float32 (denominator r)
static member instance (_Fractional:FromRational, _:decimal ) = fun (r:Rational) -> decimal (numerator r) / decimal (denominator r)
static member inline instance (_Fractional:FromRational, _:Ratio<_>) = fun (r:Rational) -> fromIntegral (numerator r) % fromIntegral (denominator r)
static member instance (_Fractional:FromRational, _:Complex ) = fun (r:Rational) -> Complex(float (numerator r) / float (denominator r), 0.0)
let inline fromRational (x:Rational) :'Fractional = Inline.instance FromRational x
let inline whenFractional a = let _ = if false then fromRational (1I % 1I) else a in ()
let inline (/) (a:'Fractional) (b:'Fractional) :'Fractional = whenFractional a; a / b
let inline recip x :'Fractional = 1G / x
// Exp functions ----------------------------------------------------------
let inline ( **^ ) (x:'Num) (n:'Integral) =
whenIntegral n
let rec f a b n = if n == 0G then a else f (b * a) b (n - 1G)
if (n < 0G) then failwith "Negative exponent" else f 1G x n
let inline ( **^^ ) (x:'Fractional) (n:'Integral) = if n >= 0G then x**^n else recip (x**^(negate n))
// RealFrac class ---------------------------------------------------------
type ProperFraction = ProperFraction with
static member instance (_RealFrac:ProperFraction, x:float , _) = fun () -> let t = truncate x in (bigint (decimal t), x - t)
static member instance (_RealFrac:ProperFraction, x:float32 , _) = fun () -> let t = truncate x in (bigint (decimal t), x - t)
static member instance (_RealFrac:ProperFraction, x:decimal , _) = fun () -> let t = truncate x in (bigint t , x - t)
static member inline instance (_RealFrac:ProperFraction, r:Ratio<_>, _) = fun () ->
let (a,b) = (numerator r, denominator r)
let (i,f) = quotRem a b
(i, f % b)
let inline properFraction (x:'RealFrac) : 'Integral * 'RealFrac =
let (a, b:'RealFrac) = Inline.instance (ProperFraction, x) ()
(fromIntegral a, b)
let inline truncate (x:'RealFrac) :'Integral = fst <| properFraction x
// Real class -------------------------------------------------------------
type ToRational = ToRational with
static member inline instance (_Real:ToRational, r:Ratio<_>, _) = fun () -> toInteger (numerator r) % toInteger (denominator r) :Rational
static member inline instance (_Real:ToRational, x:'t , _) = fun () ->
whenFractional x
let (i:Integer,d) = properFraction x
(i % 1I) + (truncate (decimal d * 1000000000000000000000000000M) % 1000000000000000000000000000I) :Rational
static member inline instance (_Real:ToRational, x:'t , _) = fun () -> (toInteger x) % 1I
let inline toRational (x:'Real) :Rational = Inline.instance (ToRational, x) ()
// Floating class ---------------------------------------------------------
type Pi = Pi with
static member instance (Pi, _:float32) = fun () -> 3.14159274f
static member instance (Pi, _:float ) = fun () -> System.Math.PI
static member instance (Pi, _:Complex) = fun () -> Complex(System.Math.PI, 0.0)
let inline pi() :'Floating = Inline.instance Pi ()
let inline ( **) a (b:'Floating) :'Floating = a ** b
let inline sqrt (x:'Floating) :'Floating = sqrt x
let inline asinh x :'Floating = log (x + sqrt (1G+x*x))
let inline acosh x :'Floating = log (x + (x+1G) * sqrt ((x-1G)/(x+1G)))
let inline atanh x :'Floating = (1G/2G) * log ((1G+x) / (1G-x))
let inline logBase x y :'Floating = log y / log x
// List functions ---------------------------------------------------------
let map, replicate, filter, head, tail = List.map, List.replicate, List.filter, List.head, List.tail
let last x = List.length x - 1 |> fun e -> x.[e]
let init x = List.init (List.length x-1) (fun e -> x.[e])
let length,reverse = List.length,List.rev
let foldr f z x = List.foldBack f x z
let rec foldr1 f = function [x] -> x | (x::xs) -> f x (foldr1 f xs) | [] -> failwith "EmptyList foldr1"
let foldl = List.fold
let rec foldl1 f = function (x::xs) -> foldl f x xs | [] -> failwith "EmptyList foldl1"
// IO ---------------------------------------------------------------------
type IO<'a> = IO of (unit->'a)
let runIO (IO f) = f()
let primretIO f = IO(fun () -> f)
let primbindIO io f = IO(fun () -> runIO (f (runIO io )))
let getLine = IO(fun() -> System.Console.ReadLine())
let putStrLn x = IO(fun() -> printfn "%s" x)
let print x = IO(fun() -> printfn "%A" x)
// Functor class ----------------------------------------------------------
type Fmap = Fmap with
static member instance (_Functor:Fmap, x:Maybe<_> , _) = fun f -> Option.map f x
static member instance (_Functor:Fmap, x:List<_> , _) = fun f -> List.map f x
static member instance (_Functor:Fmap, x:IO<_> , _) = fun f -> primbindIO x (primretIO << f)
static member instance (_Functor:Fmap, g:_->_ , _) = (>>) g
static member instance (_Functor:Fmap, e:Either<'a,'b>, _) = fun f ->
match e with
| (Left x ) -> Left x
| (Right y) -> Right (f y)
static member instance (_Functor:Fmap, x:array<_> , _) = fun f -> Array.map f x
static member instance (_Functor:Fmap, x:_ [,] , _) = fun f -> Array2D.map f x
static member instance (_Functor:Fmap, x:_ [,,] , _) = fun f -> Array3D.map f x
static member instance (_Functor:Fmap, x:_ [,,,] , _) = fun f ->
Array4D.init (x.GetLength 0) (x.GetLength 1) (x.GetLength 2) (x.GetLength 3) (fun a b c d -> f x.[a,b,c,d])
let inline fmap f x = Inline.instance (Fmap, x) f
// Monad class ------------------------------------------------------------
type Return = Return with
static member instance (_Monad:Return, _:Maybe<'a> ) = fun x -> Just x :Maybe<'a>
static member instance (_Monad:Return, _:List<'a> ) = fun x -> [x] :List<'a>
static member instance (_Monad:Return, _:IO<'a> ) = fun x -> primretIO x :IO<'a>
static member instance (_Monad:Return, _: 'r -> 'a ) = fun x -> const' x : 'r -> 'a
static member instance (_Monad:Return, _:Either<'e,'a>) = fun x -> Right x :Either<'e,'a>
let inline return' x = Inline.instance Return x
type Bind = Bind with
static member instance (_Monad:Bind, x:Maybe<_> , _:Maybe<'b> ) = fun (f:_->Maybe<'b> ) -> Option.bind f x
static member instance (_Monad:Bind, x:List<_> , _:List<'b> ) = fun (f:_->List<'b> ) -> List.collect f x
static member instance (_Monad:Bind, x:IO<_> , _:IO<'b> ) = fun (f:_->IO<'b> ) -> primbindIO x f
static member instance (_Monad:Bind, f:'r->'a , _:'r->'b ) = fun (k:_->_->'b) r -> k (f r) r
static member instance (_Monad:Bind, x:Either<'e,_>, _:Either<'e,'b>) = fun (k:_->Either<_,'b>) -> match x with
| Left l -> Left l
| Right r -> k r
let inline (>>=) x (f:_->'R) : 'R = Inline.instance (Bind, x) f
let inline (=<<) (f:_->'R) x : 'R = Inline.instance (Bind, x) f
// Do notation ------------------------------------------------------------
type DoNotationBuilder() =
member inline b.Return(x) = return' x
member inline b.Bind(p,rest) = p >>= rest
member b.Let (p,rest) = rest p
member b.ReturnFrom(expr) = expr
let do' = new DoNotationBuilder()