Fork me on GitHub

Real World Code Snippet

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
module RealWorld =

type World = private | World
and 'a Pure = private | Pure of 'a
and 'a IO = World -> ('a Pure * World)

let bind : 'a IO -> 'b IO -> 'b IO =
fun a1 a2 world0 ->
let (a,world1) = a1 world0 in
let (b,world2) = a2 world1 in
(b,world2)

let lift : 'a IO -> ('a Pure -> 'b IO) -> 'b IO =
fun a1 a2 world0 ->
let (a,world1) = a1 world0 in
let (b,world2) = a2 a world1 in
(b,world2)

let ( >> ) : 'a IO -> 'b IO -> 'b IO = bind
let ( >>= ) : 'a IO -> ('a Pure -> 'b IO) -> 'b IO = lift

let unit : unit Pure = Pure ()

let effect : ('a -> 'b) -> 'a Pure -> 'b IO =
fun f (Pure a) ->
fun world -> Pure (f a), world

let eval : unit IO -> unit Pure * World =
fun main -> main World

[<AutoOpen>]
module Don =

[<Sealed>]
type DonBuilder () =
member __.Yield (()) : unit IO = fun world -> unit,world
[<CustomOperation("bind")>]
member __.Bind' (a1, a2) = bind a1 a2
[<CustomOperation("lift")>]
member __.LiftM (a1, a2) = lift a1 a2

let don = new DonBuilder ()

Real World Code output:

module RealWorld = begin
type World = private | World
and 'a Pure = private | Pure of 'a
and 'a IO = World -> 'a Pure * World
val bind : a1:'a IO -> a2:'b IO -> world0:World -> 'b Pure * World
val lift :
a1:'a IO -> a2:('a Pure -> 'b IO) -> world0:World -> 'b Pure * World
val ( >> ) : ('a IO -> 'b IO -> 'b IO)
val ( >>= ) : ('a IO -> ('a Pure -> 'b IO) -> 'b IO)
val unit : unit Pure = Pure ()
val effect : f:('a -> 'b) -> 'a Pure -> 'b IO
val eval : main:unit IO -> unit Pure * World
module Don = begin
type DonBuilder =
class
new : unit -> DonBuilder
member Bind' : a1:'c IO * a2:'d IO -> 'd IO
member LiftM : a1:'a IO * a2:('a Pure -> 'b IO) -> 'b IO
member Yield : unit -> unit IO
end
val don : DonBuilder
end
end

Utils Code Snippet

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
module Util =

open RealWorld

module Random =
let private r = new System.Random ()
let next ( ) = r.Next ()

module Read =
let readInt () = System.Console.Read ()
let readKey () = System.Console.ReadKey ()
let readLine () = System.Console.ReadLine ()

let (!) : 'a -> 'a IO =
fun a -> effect (fun _ -> a) unit

let getRand : int IO =
effect Random.next unit

let putInt : int Pure -> unit IO =
effect <| printf "%i"

let readLn : string IO =
effect Read.readLine unit

let putStr : string Pure -> unit IO =
effect <| printf "%s"

let putStrLn : string Pure -> unit IO =
effect <| printfn "%s"

let sample1 : unit IO =
! "What is your name?"
>>= putStrLn
>> readLn
>>= fun a ->
! "How old are you?"
>>= putStrLn
>> readLn
>>= fun b ->
putStr a
>> ! ","
>>= putStr
>> putStrLn b

let sample2 : unit IO = don {
bind ! "What is your name?"
lift putStrLn
bind readLn

lift (fun a -> don {
bind ! "How old are you?"
lift putStrLn
bind readLn

lift (fun b -> don {
bind (putStr a)
bind ! ","
lift putStr
bind (putStrLn b)

})
})
}

Utils Code output:

module Util = begin
module Random = begin
val private r : System.Random
val next : unit -> int
end
module Read = begin
val readInt : unit -> int
val readKey : unit -> System.ConsoleKeyInfo
val readLine : unit -> string
end
val ( ! ) : a:'a -> 'a RealWorld.IO
val getRand : int RealWorld.IO
val putInt : (int RealWorld.Pure -> unit RealWorld.IO)
val readLn : string RealWorld.IO
val putStr : (string RealWorld.Pure -> unit RealWorld.IO)
val putStrLn : (string RealWorld.Pure -> unit RealWorld.IO)
val sample1 : unit RealWorld.IO
val sample2 : unit RealWorld.IO
end

Execution Code Snippet

let _ = Util.sample1 |> RealWorld.eval, Util.sample2 |> RealWorld.eval
mon@razerRamon:~/tmp/realWorld$ ./RealWorld.fsx

Execution Code output:

What is your name?
John Doe
How old are you?
42
John Doe,42
What is your name?
John Doe
How old are you?
42
John Doe,42

References:

Picture by Fernando Frazão/Agência Brasil, (CC BY 3.0 BR)

Status

Submission accepted on Kattis Problem Archive

Files

mon@razerRamon:~/tmp/ncpc17$ ll
total 109M
drwxrwxr-x 3 mon mon 4.0K Oct 14 16:42 assets/
drwxrwxr-x 13 mon mon 4.0K Oct 14 12:34 ncpc2017-testdata/
-rwxrwxr-x 1 mon mon 257 Oct 14 16:19 BestRelayTeam.bash*
-rwxrwxr-x 1 mon mon 4.0K Oct 14 16:23 BestRelayTeam.hs*
-rw-rw-r-- 1 mon mon 699 Oct 14 16:24 BestRelayTeam.sample.output
-rw-rw-r-- 1 mon mon 138K Oct 14 16:24 BestRelayTeam.secret.output
-rw-rw-r-- 1 mon mon 59K Oct 7 12:19 Language Haskell - Kattis, The 2017 Nordic Collegiate Programming Contest.pdf
-rw-rw-r-- 1 mon mon 4.7M Oct 7 12:29 ncpc2017problems.pdf
-rw-rw-r-- 1 mon mon 104M Oct 11 09:00 ncpc2017-testdata.tar.bz2
-rwxrwxr-x 1 mon mon 1.2K Oct 14 14:00 ScriptTemplate.hs*
-rw-rw-r-- 1 mon mon 8 Oct 7 12:42 ScriptTemplate.input
mon@razerRamon:~/tmp/ncpc17$

Haskell Code Snippet

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
#!/usr/bin/env stack
{- stack
--resolver ghc-7.10.3
--install-ghc
runghc
--
-rtsopts -ferror-spans
+RTS -M1024m -K8m -RTS
-}


{-
* GHC used by NCPC:
The Glorious Glasgow Haskell Compilation System version 7.10.3

* Flags required by NCPC:
-O2 -threaded -rtsopts -ferror-spans
+RTS -M{memlim}m -K8m -RTS

... but, due to warnings (ignored), some are removed:
when making flags consistent: Warning:
-O conflicts with --interactive; -O ignored.
Warning: -debug, -threaded and -ticky are ignored by GHCi

* Flags in order to make optimal code (exhaustive):
-Wall -Werror

... but if used, it would require way more code (time is mana)
-}


module Main (main) where

data Runner = Runner
{ surname :: String
, fstleg :: Double
, sndleg :: Double
}

data Runners = Runners
{ number :: Int
, athletes :: [Runner]
}

data RelayTeam = RelayTeam
{ time :: Double
, first :: Runner
, second :: Runner
, third :: Runner
, fourth :: Runner
}

instance Eq Runner where
Runner name1 fstleg1 sndleg1 == Runner name2 fstleg2 sndleg2 =
name1 == name2 && fstleg1 == fstleg2 && sndleg1 == sndleg2
Runner name1 fstleg1 sndleg1 /= Runner name2 fstleg2 sndleg2 =
name1 /= name2 || fstleg1 /= fstleg2 || sndleg1 /= sndleg2

instance Read Runner where
readsPrec _ input =
let
aux [ ] = []
aux (name:fstleg:sndleg:[]) =
[(Runner name (read fstleg) (read sndleg), "")]
aux [ _ ] = []
in
aux $ words input

instance Read Runners where
readsPrec _ input =
let
aux [ ] = []
aux (x:xs) =
let
nr = read x
in
[(Runners nr (aux' nr xs), "")]
aux' 0 [ ] = [ ]
aux' n (x:xs) = (read x) : aux' (n-1) xs
in
aux $ lines input

instance Show Runner where
show (Runner surname _ _) = surname

instance Show RelayTeam where
show (RelayTeam time first second third fourth) =
show time ++ "\n" ++
show first ++ "\n" ++
show second ++ "\n" ++
show third ++ "\n" ++
show fourth ++ "\n"

nrdec :: Double -> Int -> Double
nrdec x n =
fromIntegral (round $ x * z) / z
where z = 10 ^ n

solve :: Runners -> RelayTeam
solve (Runners _ xs) =
let
dummy = Runner "DUMMY" 9999.99 9999.99
init = (dummy,dummy,dummy,dummy)

ftime (Runner _ t _) = t
stime (Runner _ _ t) = t
bstime (a,b,c,d) (w,x,y,z) =
stime a + stime b + stime c + stime d <
stime w + stime x + stime y + stime z
bctime (a,b,c,d) (w,x,y,z) =
ftime a + stime b + stime c + stime d <
ftime w + stime x + stime y + stime z

aux (a,b,c,d) _ [ ] =
RelayTeam (nrdec (ftime a + stime b + stime c + stime d) 2) a b c d
aux acc (a,b,c,d) (y:ys) =
{- Linear time with only 8 extra memory usage -}
let
abcd =
if a == y then
(y,b,c,d)
else
if b == y then
(y,a,c,d)
else
if c == y then
(y,a,b,d)
else
(y,a,b,c)
in
if bctime abcd acc then
aux abcd (a,b,c,d) ys
else
aux acc (a,b,c,d) ys

aux' (a,b,c,d) [ ] = (a,b,c,d)
aux' (a,b,c,d) (y:ys) =
{- Linear time with only 4 extra memory usage -}
if bstime (y,b,c,d) (a,b,c,d) then
aux' (y,b,c,d) (a:ys)
else
if bstime (a,y,c,d) (a,b,c,d) then
aux' (a,y,c,d) (b:ys)
else
if bstime (a,b,y,d) (a,b,c,d) then
aux' (a,b,y,d) (c:ys)
else
if bstime (a,b,c,y) (a,b,c,d) then
aux' (a,b,c,y) (d:ys)
else
aux' (a,b,c,d) ys
in
aux init (aux' init xs) xs

readInput :: String -> Runners
readInput =
read

writeOutput :: RelayTeam -> String
writeOutput =
show

main :: IO ()
main =
interact $ writeOutput . solve . readInput

Haskell Code output:

BestRelayTeam.bash

#!/bin/bash

for f in $1*.in; do
echo " "
echo "- "$f
cat $f
echo "- "${f%.*}.ans
cat ${f%.*}.ans
echo "- result:"
cat $f | ./BestRelayTeam.hs
echo "- diff:"
cat $f | ./BestRelayTeam.hs | diff - ${f%.*}.ans
done

BestRelayTeam (sample)

./BestRelayTeam.bash ncpc2017-testdata/bestrelayteam/sample/

BestRelayTeam (sample output)

 
- ncpc2017-testdata/bestrelayteam/sample/1.in
6
ASHMEADE 9.90 8.85
BLAKE 9.69 8.72
BOLT 9.58 8.43
CARTER 9.78 8.93
FRATER 9.88 8.92
POWELL 9.72 8.61
- ncpc2017-testdata/bestrelayteam/sample/1.ans
35.54
CARTER
BOLT
POWELL
BLAKE
- result:
35.54
CARTER
BOLT
POWELL
BLAKE
- diff:

- ncpc2017-testdata/bestrelayteam/sample/2.in
9
AUSTRIN 15.60 14.92
DRANGE 15.14 14.19
DREGI 15.00 14.99
LAAKSONEN 16.39 14.97
LUNDSTROM 15.83 15.35
MARDELL 13.36 13.20
POLACEK 13.05 12.55
SANNEMO 15.23 14.74
SODERMAN 13.99 12.57
- ncpc2017-testdata/bestrelayteam/sample/2.ans
52.670000
MARDELL
POLACEK
SODERMAN
DRANGE
- result:
52.67
MARDELL
POLACEK
SODERMAN
DRANGE
- diff:
1c1
< 52.67
---
> 52.670000

BestRelayTeam (secret)

./BestRelayTeam.bash ncpc2017-testdata/bestrelayteam/secret/

BestRelayTeam (secret output, only diff)

- ncpc2017-testdata/bestrelayteam/secret/01-crazy.in
10
QXBINSJS 10.91 8.16
WKN 18.65 15.09
CPP 16.38 9.38
KDNLKJMYIWFSGYWY 12.53 11.18
KXS 19.64 13.63
OYCJANFTSGQTZMIJD 16.16 8.32
ZKGNNS 17.32 16.16
LDOYLWRXVXAJEVDOWXNF 13.02 12.58
IVONUZJE 11.52 10.37
KMEVNRHQSQPUYEYBP 18.71 9.63
- ncpc2017-testdata/bestrelayteam/secret/01-crazy.ans
37.38
IVONUZJE
QXBINSJS
OYCJANFTSGQTZMIJD
CPP
- result:
37.38
IVONUZJE
QXBINSJS
OYCJANFTSGQTZMIJD
CPP
- diff:

- ncpc2017-testdata/bestrelayteam/secret/02-crazy.in
50

...

- ncpc2017-testdata/bestrelayteam/secret/15-sequential.ans
60.06
GGURGO
NXZUEOA
BOHPBXMYSTFJUPUA
IOYBAEDMKSKO
- result:
60.06
IOYBAEDMKSKO
GGURGO
NXZUEOA
BOHPBXMYSTFJUPUA
- diff:
2d1
< IOYBAEDMKSKO
5a5
> IOYBAEDMKSKO

...

- ncpc2017-testdata/bestrelayteam/secret/30-sequential-secondbest-firstpart.ans
51.99
SECONDBEST
BEST
JMBCIRVTIHVRKRZZTXSD
RJZMGLUWHOJBLQGIUWZD
- result:
51.99
SECONDBEST
BEST
JMBCIRVTIHVRKRZZTXSD
QQYBKUPSWYKJCUODUSMA
- diff:
5c5
< QQYBKUPSWYKJCUODUSMA
---
> RJZMGLUWHOJBLQGIUWZD

References:

Code Snippet

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
(* This construct is for ML compatibility. The syntax '(typ,...,typ) ident'
is not used in F# code. Consider using 'ident<typ,...,typ>' instead. *)

#nowarn "62"

module Error =

type fromException =
{ message : string
; hresult : int
; stacktrace : string
}

let exn2error : System.Exception -> fromException =
fun ex ->
{ message = ex.Message
; hresult = ex.HResult
; stacktrace = ex.StackTrace
}

module Monad =

(* Inspired by: Eirik Tsarpalis http://fssnip.net/7TF *)

type ('a,'b) flow = ('a,'b) Choice

let success : 'a -> ('a,'b) flow = fun x -> Choice1Of2 x
let failure : 'b -> ('a,'b) flow = fun x -> Choice2Of2 x

let (|Success|Failure|) : ('a,'b) flow -> ('a,'b) flow = id

let catch : (exn -> 'b) -> 'a Async -> ('a,'b) flow Async =
fun f m ->
async {
let! x = Async.Catch m

return
match x with
| Success y -> y |> success
| Failure e -> e |> f |> failure
}

let bind : ('a -> ('c,'b) flow) -> ('a,'b) flow -> ('c,'b) flow =
fun f ->
function
| Success x -> x |> f
| Failure x -> x |> failure

let (>>=) m f = bind f m

module Web =

open Monad

(* Don Syme Blog: "Introducing F# Asynchronous Workflows"

https://blogs.msdn.microsoft.com/dsyme/
2007/10/10/introducing-f-asynchronous-workflows/ *)


open System.IO
open System.Net

type request = GET | POST

let syncHttp : string -> string =
fun url ->
// Create the web request object
let req = WebRequest.Create url

// Get the response, synchronously
let rsp = req.GetResponse ()

// Grab the response stream and a reader. Clean up when we're done
use stream = rsp.GetResponseStream ()
use reader = new StreamReader(stream)

// Synchronous read-to-end, returning the flow
reader.ReadToEnd()

let asyncHttp : string -> string Async =
fun url ->
async {
// Create the web request object
let req = WebRequest.Create url

// Get the response, asynchronously
// let! rsp = req.GetResponseAsync () (* API changes since blog post *)
let! rsp = req.AsyncGetResponse ()

// Grab the response stream and a reader. Clean up when we're done
use stream = rsp.GetResponseStream ()
use reader = new StreamReader(stream)

// synchronous read-to-end
return reader.ReadToEnd ()
}

let asyncHttp' : (exn -> 'a) -> (string * string) list -> request -> string
-> (string,'a) flow Async =
fun error headers request url ->
async {
// Create the web request object
let req = WebRequest.Create url

req.Method <- sprintf "%A" request
req.ContentLength <- 0L
req.Timeout <- System.Threading.Timeout.Infinite

headers
|> List.iter(fun (k,v) -> req.Headers.Add(k,v))

// Get the response, asynchronously
// let! rsp = req.GetResponseAsync () (* API changes since blog post *)
let! rsp = req.AsyncGetResponse ()

// Grab the response stream and a reader. Clean up when we're done
use stream = rsp.GetResponseStream ()
use reader = new StreamReader(stream)

// synchronous read-to-end
return reader.ReadToEnd ()
} |> Monad.catch error

module Translate =

(* https://msdn.microsoft.com/en-us/library/ff512421.aspx *)

open System.Net

open Monad
open Web

type fail = Unexpected of Error.fromException

let inline (=>) x y = x,y

let urlenc : string -> string = WebUtility.UrlEncode

let urlToken = "https://api.cognitive.microsoft.com/sts/v1.0/issueToken"
let urlTrans = "https://api.microsofttranslator.com/v2/Http.svc/Translate"

let token : string -> (string,fail) flow Async =
fun key ->
let headers =
[ "Ocp-Apim-Subscription-Key" => key
]
urlToken |> asyncHttp' (Error.exn2error >> Unexpected) headers POST

let text : string -> string -> string -> string -> (string,fail) flow Async =
fun input fromTag toTag token ->
let query =
sprintf "%s?text=%s&from=%s&to=%s&contentType=text/plain"
urlTrans (urlenc input) fromTag toTag
let headers =
[ "Authorization" => sprintf "Bearer %s" token
]
query |> asyncHttp' (Error.exn2error >> Unexpected) headers GET

open Monad

let apikey = "omitted api key for obvious reasons"

let english = "Use pixels to express measurements for padding and margins."

(* Language Tag: https://msdn.microsoft.com/en-us/library/cc233982.aspx *)
let en = "en"
let da = "da"

Translate.token apikey
|> Async.RunSynchronously
|> function
| Success token ->
Translate.text english en da token
|> Async.RunSynchronously
|> printfn "%A"
| Failure error ->
error
|> printfn "%A"

Code output:

> module Error = begin
type fromException =
{message: string;
hresult: int;
stacktrace: string;}
val exn2error : ex:System.Exception -> fromException
end
module Monad = begin
type ('a,'b) flow = Choice<'a,'b>
val success : x:'a -> ('a,'b) flow
val failure : x:'b -> ('a,'b) flow
val ( |Success|Failure| ) : (('a,'b) flow -> ('a,'b) flow)
val catch : f:(exn -> 'b) -> m:Async<'a> -> Async<('a,'b) flow>
val bind : f:('a -> ('c,'b) flow) -> _arg1:('a,'b) flow -> ('c,'b) flow
val ( >>= ) : m:('a,'b) flow -> f:('a -> ('c,'b) flow) -> ('c,'b) flow
end
module Web = begin
type request =
| GET
| POST
val syncHttp : url:string -> string
val asyncHttp : url:string -> Async<string>
val asyncHttp' :
error:(exn -> 'a) ->
headers:(string * string) list ->
request:request -> url:string -> Async<(string,'a) Monad.flow>
end
module Translate = begin
type fail = | Unexpected of Error.fromException
val inline ( => ) : x:'a -> y:'b -> 'a * 'b
val urlenc : arg00:string -> string
val urlToken : string =
"https://api.cognitive.microsoft.com/sts/v1.0/issueToken"
val urlTrans : string =
"https://api.microsofttranslator.com/v2/Http.svc/Translate"
val token : key:string -> Async<(string,fail) Monad.flow>
val text :
input:string ->
fromTag:string ->
toTag:string -> token:string -> Async<(string,fail) Monad.flow>
end
val apikey : string = "omitted api key for obvious reasons"
val english : string =
"Use pixels to express measurements for padding and margins."
val en : string = "en"
val da : string = "da"

> Choice1Of2
"<string xmlns="http://schemas.microsoft.com/2003/10/Serialization/">
Brug pixel til at udtrykke målinger for polstring og margener.
</string>"
val it : unit = ()

References:

Utils Code Snippet

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
module Util = struct                                                          

type (α,β) result =
| Ok of α
| Err of β

let success : α (α,β) result = λ x Ok x
let failure : β (α,β) result = λ x Err x

let fmap : (α β) (α,γ) result (β,γ) result = λ f
function
| Ok x Ok (f x)
| Err e Err e
let (<$>) : (α β) (α,γ) result (β,γ) result = fmap

let liftM : (α,γ) result (α (β,γ) result) (β,γ) result = λ m f
match m with
| Ok x f x
| Err e Err e
let (>>=) : (α,γ) result (α (β,γ) result) (β,γ) result = liftM

let compose_left : (α β) (β γ) α γ = λ f g x g(f x)
let (>>) : (α β) (β γ) α γ = compose_left

let safe_find : (α bool) α list α option = λ f xs
let rec aux = function
| [ ] None
| x::xs
if f x then
Some x
else
aux xs
in
aux xs

let string_to_chars : string char list = λ x
let rec aux acc = function
| 0 acc
| i aux (x.[i-1] :: acc) (i-1)
in aux [] (String.length x)

end

Utils Code output:

module Util :
sig
type ('a, 'b) result = Ok of 'a | Err of 'b
val success : 'a -> ('a, 'b) result
val failure : 'b -> ('a, 'b) result
val fmap : ('a -> 'b) -> ('a, 'c) result -> ('b, 'c) result
val ( <$> ) : ('a -> 'b) -> ('a, 'c) result -> ('b, 'c) result
val liftM : ('a, 'c) result -> ('a -> ('b, 'c) result) -> ('b, 'c) result
val ( >>= ) :
('a, 'c) result -> ('a -> ('b, 'c) result) -> ('b, 'c) result
val compose_left : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
val safe_find : ('a -> bool) -> 'a list -> 'a option
val string_to_chars : string -> char list
end

Lambda Calculus Code Snippet

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
module LambdaCalculus = struct                                                

open Printf
open Util

type error =
| InvalidToken
| NoClojureParse
| InvalidParse
| UnboundVariable
| NoClojureEval

type expr =
| Var of name
| Lam of name * body
| App of expr * expr
and name = char
and body = expr

type token =
| ParLeft
| ParRight
| Lambda
| Dot
| Variable of char

type env = (char * expr) list

let alphabet =
[
'a';'b';'c';'d';'e';'f';'g';'h';'i';'j';'k';'l';'m';
'n';'o';'p';'q';'r';'s';'t';'u';'v';'w';'x';'y';'z';
]

let rec tokenize : char list (token list,error) result = function
| [ ] [ ] |> success
| ' ' :: xs tokenize xs
| '(' :: xs tokenize xs >>= λ ys ParLeft :: ys |> success
| ')' :: xs tokenize xs >>= λ ys ParRight :: ys |> success
| '^' :: xs tokenize xs >>= λ ys Lambda :: ys |> success
| '.' :: xs tokenize xs >>= λ ys Dot :: ys |> success
| var :: xs
if List.mem var alphabet
then tokenize xs >>= λ ys Variable var :: ys |> success
else InvalidToken |> failure

let rec parse_aux : token list (expr * token list,error) result = function
| Variable var :: xs (Var var, xs) |> success
| Lambda :: Variable var :: Dot :: xs
parse_aux xs >>=
λ (body,tokens) (Lam (var,body), tokens) |> success
| ParLeft :: xs
parse_aux xs >>=
(λ (func,ys)
parse_aux ys >>=
(λ (value,zs)
match zs with
| ParRight :: tokens (App (func,value), tokens) |> success
| __________________ NoClojureParse |> failure
)
)
| _________________________________ InvalidParse |> failure
let parse : token list (expr,error) result = λ xs
fst <$> parse_aux xs

let rec eval_aux : env expr (env * expr,error) result = λ env
function
| Var var
let result =
match safe_find (λ (v,t) var = v) env with
| Some (_,expr) ([],expr) |> success
| None UnboundVariable |> failure
in result
| Lam (var, body)
(env, Lam (var, body)) |> success
| App (func, value)
eval_aux env func >>= function
| closed_env, Lam (var, body)
eval_aux env value >>= λ (_,eval_value)
eval_aux ((var,eval_value) :: closed_env) body
| ___________________________ NoClojureEval |> failure
let eval : expr (expr,error) result = λ xs
snd <$> eval_aux [] xs

let rec pretty_printer : expr (string,error) result = function
| Var var
sprintf "%c" var |> success
| Lam (var,body)
pretty_printer body >>= λ x
sprintf "^%c.%s" var x |> success
| App (func,value)
pretty_printer func >>= λ x
pretty_printer value >>= λ y
sprintf "(%s %s)" x y |> success

let interpret : string (string,error) result = λ x
string_to_chars x |> success
>>= tokenize
>>= parse
>>= eval
>>= pretty_printer

end

Lambda Calculus Code output:

module LambdaCalculus :
sig
type error =
InvalidToken
| NoClojureParse
| InvalidParse
| UnboundVariable
| NoClojureEval
type expr = Var of name | Lam of name * body | App of expr * expr
and name = char
and body = expr
type token = ParLeft | ParRight | Lambda | Dot | Variable of char
type env = (char * expr) list
val alphabet : char list
val tokenize : char list -> (token list, error) Util.result
val parse_aux : token list -> (body * token list, error) Util.result
val parse : token list -> (expr, error) Util.result
val eval_aux : env -> body -> (env * expr, error) Util.result
val eval : expr -> (expr, error) Util.result
val pretty_printer : body -> (string, error) Util.result
val interpret : string -> (string, error) Util.result
end

Assertions Code Snippet

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
module AssertLambdaCalculus = struct                                          

open Util

let simple : bool =
LambdaCalculus.interpret "^x.x" =
Ok "^x.x"

let complex : bool =
LambdaCalculus.interpret "((^x.^y.x ^a.(a a)) ^b.b)" =
Ok "^a.(a a)"

(* let omega : bool =
LambdaCalculus.interpret "(^x.(x x) ^x.(x x))" =
Ok "Infinte loop, never terminates" *)


end

Assertions Code output:

module AssertLambdaCalculus : 
sig
val simple : bool
val complex : bool
end

AssertLambdaCalculus.simple;;
- : bool = true
AssertLambdaCalculus.complex;;
- : bool = true

References:

  • Michael Gilliland, Let’s Write a Lambda Calculus in F# video series:

Files

mon@razerRamon:~/tmp/DataRegister$ ll -R
.:
total 16K
drwxrwxr-x 2 mon mon 4.0K Jul 17 13:04 dataleaks/
-rwxrwxr-x 1 mon mon 1.6K Jul 17 13:02 DataRegister.fsx*

./dataleaks:
total 0
mon@razerRamon:~/tmp/DataRegister$

Code Snippet

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
(* Ported from Haskell snippet *)
module Data =
type 'a Sensitive = Sensitive of 'a
type 'a Register = private Data of 'a list

let sensitive = Sensitive

let init : unit -> 'a Register =
fun () ->
Data []

let add : 'a -> 'a Register -> 'a Register =
fun x (Data reg) ->
if List.exists (fun y -> x = y) reg then
Data reg
else
Data (x :: reg)

let count : ('a -> bool) -> 'a Register -> int =
fun cond (Data reg) ->
reg
|> List.filter cond
|> List.length

let get : ('a -> 'b) -> ('a -> bool) -> 'a Register -> 'b option =
fun dto cond (Data reg) ->
match List.tryFind cond reg with
| Some x -> Some (dto x)
| None -> None

(* Sensitive data generator *)
module Random =
open System
let private r = new Random()
let next () = r.Next()

open Data
open Random

(* Some domain type *)
type FooBar = { foo : int; bar : int Sensitive; }

let uids = [1 .. 10]

let data =
uids
|> List.fold(
fun a x ->
Data.add
{ foo = x; bar = Data.sensitive (Random.next ()) } a
) (Data.init())

(* Good person *)
let user1 : int option =
data
|> Data.get
(fun { bar = (Sensitive num) } -> num)
(fun x -> x.foo = 7)

(* Bad person *)
let user2 : int option =
let leak : FooBar -> unit =
fun { foo = uid; bar = (Sensitive num) } ->
System.IO.File.WriteAllText(
"./dataleaks/" + (Random.next ()).ToString() + ".log",
sprintf "(%i,%i)\n" uid num
)

data
|> Data.get
(fun { FooBar.bar = (Sensitive num) } -> num)
(fun x -> leak x; x.foo = 7)

(*
Ensure to " ... implement appropriate TECHNICAL and organizational measures,
..., which are DESIGNED to implement data-protection principles, ..., in an
effective manner and to integrate the necessary SAFEGUARDS into the processing
in order to meet the requirements of this Regulation and protect the rights of
data subjects" (Article 25(1) EU GDPR).
*)

Code output:

>
module Data = begin
type 'a Sensitive = | Sensitive of 'a
type 'a Register = private | Data of 'a list
val sensitive : arg0:'a -> 'a Sensitive
val init : unit -> 'a Register
val add : x:'a -> 'a Register -> 'a Register when 'a : equality
val count : cond:('a -> bool) -> 'a Register -> int
val get : dto:('a -> 'b) -> cond:('a -> bool) -> 'a Register -> 'b option
end
module Random = begin
val private r : System.Random
val next : unit -> int
end
type FooBar =
{foo: int;
bar: int Data.Sensitive;}
val uids : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]
val data : FooBar Data.Register
val user1 : int option = Some 235432072
val user2 : int option = Some 235432072

Data leak

mon@razerRamon:~/tmp/DataRegister$ ll -R && cat dataleaks/*
.:
total 16K
drwxrwxr-x 2 mon mon 4.0K Jul 17 13:19 dataleaks/
-rwxrwxr-x 1 mon mon 2.3K Jul 17 13:20 DataRegister.fsx*

./dataleaks:
total 48K
-rw-rw-r-- 1 mon mon 15 Jul 17 13:19 1213109609.log
-rw-rw-r-- 1 mon mon 14 Jul 17 13:19 1312310136.log
-rw-rw-r-- 1 mon mon 14 Jul 17 13:19 1690673176.log
-rw-rw-r-- 1 mon mon 14 Jul 17 13:19 801806650.log
(10,996092411)
(8,764617439)
(9,423553051)
(7,235432072)
mon@razerRamon:~/tmp/DataRegister$

References: