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: