Fork me on GitHub
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:

Files

mon@razerRamon:~/tmp/haskell/dataregister$ ll
total 40K
-rw-rw-r-- 1 mon mon 1.4K Jul 14 14:59 DataRegister.hs
-rw-rw-r-- 1 mon mon 130 Jul 13 14:49 Guests.csv
-rwxrwxr-x 1 mon mon 5.5K Jul 14 15:01 Script.hs*
mon@razerRamon:~/tmp/haskell/dataregister$

Guest list

1
2
3
4
Regular;Joe;US-CA1234;-;-;
Muhammad;Ali;US-KY1942;-;Islam;
Don;Rickles;US-NY1926;-;Judaism;
Al;Gore;US-WA1948;Vegan;Christianism;

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
module DataRegister (
{- Data (type) is not exposed. Which ensures that data processing needs to be
performed with the exposed functions
-}

Register,
Sensitive(..),
add,count,exists,get,populate
) where

import qualified Data.List as List
import qualified Data.Maybe as Maybe

data Sensitive a = Sensitive a deriving (Eq)
data Register a = Data [a]

add :: (Eq a) => a -> Register a -> Register a
add x (Data reg) =
if List.any (\y -> x == y) reg then
Data reg
else
Data (x : reg)

count :: (a -> Bool) -> Register a -> Int
count cond (Data reg) =
let
xs = List.filter cond reg
in
List.length xs

exists :: (a -> Bool) -> Register a -> Bool
exists cond (Data reg) =
{- Junior Dev also likes to debug a lot:

putStrLn ("Debugging is the only way I know: " ++ (show reg))

And computer says NO:
Couldn't match type ‘IO’ with ‘Bool’
-}

List.any cond reg

get :: (a -> b) -> (a -> Bool) -> Register a -> Maybe b
get ___ ____ (Data [ ]) = Nothing
get dto cond (Data (x:xs)) =
if cond x then
Just (dto x)
else
get dto cond (Data xs)

populate :: FilePath -> (String -> Maybe a) -> IO (Register a)
populate path dto =
do
file <- readFile path
let ls = lines file
let ms = map dto ls
let ds = Maybe.catMaybes ms
return (Data ds)
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
#!/usr/bin/env stack
{- stack
--resolver lts-8.21
--install-ghc
runghc
--package split
--
-Wall -Werror
-}


{-

Why Are So Many Smart People So Stupid About the GDPR?

"One example: The requirement for data minimization (Article 5(1)(c)) means that
you must be able to demonstrate that every business process that touches
personal data (and every technology that contributes to it) is designed in such
a way that it uses the smallest possible amount of data for the shortest
possible period of time while exposing it to the fewest possible eyeballs and
ensuring that it is deleted as quickly as possible when the processing purpose
is completed." -- Tim Walters, Ph.D. (Customer Experience and GDPR Consultant,
Writer, and Keynote Speaker)


Possible solution:

1) Create a stateless app. Processed data is never stored, only in memory, which
will be reset when the application terminates.

2) Ensure that only necessary data is used. It's mandatory to provide the
feature of marking data as sensitive data.

3) As many people are going to use the data, ensure to narrow down each
functionality to a specific process.

4) 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)). Haskell does a pretty good job isolating
side-effects. If you want to debug, log or simple print, you will have to build
it into the design of the system. No shortcuts allowed.


Example:

Celebrity BBQ event. A lot of well know people will participate at the BBQ. Some
of the guests will not be able to enjoy the chefs main specialty, spareribs,
due to diet or religious views. As we would like to make the event a success for
everybody we will retrieve the necessary data from the A-list guests. As some of
the data is sensitive, we will need to ensure it doesn't get misused by the
staff.

-}


module Main (main) where

import qualified Data.List.Split as Split

import DataRegister (Register,Sensitive(..),count,get,populate)

data Religion = Buddhism | Christianism | Hinduism | Islam | Judaism {- ... -}
deriving (Eq)
data Diets = Vegan | Vegetarian
deriving (Eq)
data Badge = Badge String String
deriving (Eq,Show)
data Guest = Guest
{ name :: Badge {- Guest must were name badges -}
, passid :: Sensitive String {- Very fancy and exclusive BBQ -}
, diets :: Maybe Diets {- No meat is a valid option -}
, religion :: Sensitive (Maybe Religion) {- No pork is also a valid option -}
}
deriving (Eq)

{- Data transfer object: From some source to our register -}
dto :: String -> Maybe Guest
dto line =
let
veg x =
case x of
"Vegan" -> Just Vegan
"Vegetarian" -> Just Vegetarian
_ -> Nothing

rel x =
case x of
"Buddhism" -> Just Buddhism
"Christianism" -> Just Christianism
"Hinduism" -> Just Hinduism
"Islam" -> Just Islam
"Judaism" -> Just Judaism
_ -> Nothing

xs = Split.splitOn ";" line
in
Just Guest
{ name = Badge (xs !! 0) (xs !! 1)
, passid = Sensitive (xs !! 2)
, diets = veg (xs !! 3)
, religion = Sensitive (rel (xs !! 4))
}

{- Needed by the Kitchen -}
spareribs :: Guest -> Bool
spareribs (Guest {diets = d, religion = (Sensitive r)}) =
let
veg = (d == (Just Vegan)) || (d == (Just Vegetarian))
rel = (r == (Just Islam)) || (r == (Just Judaism ))
in
veg || rel

{- Needed by the Bouncer -}
scandid :: String -> Guest -> Bool
scandid pid (Guest { passid = (Sensitive regpid)}) =
pid == regpid
givebadge :: Guest -> Badge
givebadge (Guest { name = badge }) =
badge
get' :: (Guest -> Bool) -> Register Guest -> Maybe Badge
get' =
get givebadge

main :: IO ()
main =
do
{- Receive guest list (from file but could be from DB or WS) -}
reg <- populate "./Guests.csv" dto

{- Junior Dev likes to log a lot:

putStrLn ("Logging it all cos big brother syndrome: " ++ (show reg))

And computer says NO:
No instance for (Show (DataRegister.Register Guest))
-}


{- Notify kitchen on how many will not eat the main dish (spareribs) -}
let n = count spareribs reg
putStrLn ("Number of guests that will not eat spareribs: " ++ show n)

{- White pride kitchen staff wants the list for ...:

putStrLn ("I have a low IQ: " ++ (show reg))

And computer says NO:
No instance for (Show (DataRegister.Register Guest))
-}


{- Bouncer will check guests for valid ids and handle badges -}
let (Just g1) = get' (scandid "US-NY1926") reg
putStrLn ("1st Guest valid id, handle: " ++ (show g1))
let (Just g2) = get' (scandid "US-CA1234") reg
putStrLn ("2nd Guest valid id, handle: " ++ (show g2))
let notguest = get' (scandid "DK-BH0000") reg
putStrLn ("... Guest indvalid id, handle: " ++ (show notguest))
let (Just g3) = get' (scandid "US-KY1942") reg
putStrLn ("3rd Guest valid id, handle: " ++ (show g3))
let (Just g4) = get' (scandid "US-WA1948") reg
putStrLn ("4th Guest valid id, handle: " ++ (show g4))

{- Dodgy Bouncer ask for a full list of all guests:

putStrLn ("I'm earning an extra buck (TMZ): " ++ (show reg))

And computer says NO:
No instance for (Show (DataRegister.Register Guest))
-}

Haskell Code output:

mon@razerRamon:~/tmp/haskell/dataregister$ ./Script.hs 
Number of guests that will not eat spareribs: 3
1st Guest valid id, handle: Badge "Don" "Rickles"
2nd Guest valid id, handle: Badge "Regular" "Joe"
... Guest indvalid id, handle: Nothing
3rd Guest valid id, handle: Badge "Muhammad" "Ali"
4th Guest valid id, handle: Badge "Al" "Gore"
mon@razerRamon:~/tmp/haskell/dataregister$

References: