I've got 99 Problems - and OCaml is all of them (Logic and codes)

Problemset

Logic and Codes

Let us define a small "language" for boolean expressions containing variables:

# type bool_expr =
    | Var of string
    | Not of bool_expr
    | And of bool_expr * bool_expr
    | Or of bool_expr * bool_expr;;
type bool_expr =
    Var of string
  | Not of bool_expr
  | And of bool_expr * bool_expr
  | Or of bool_expr * bool_expr

A logical expression in two variables can then be written in prefix notation. For example, (a ∨ b) ∧ (a ∧ b) is written:

# And(Or(Var "a", Var "b"), And(Var "a", Var "b"));;
- : bool_expr = And (Or (Var "a", Var "b"), And (Var "a", Var "b"))

Truth tables for logical expressions (2 variables). (medium)

Define a function, table2 which returns the truth table of a given logical expression in two variables (specified as arguments). The return value must be a list of triples containing(value_of_a, balue_of_b, value_of_expr).

let table2 e1 e2 expr =
let rec eval e1 e2 e1val e2val = function
| And (a, b) -> eval e1 e2 e1val e2val a && eval e1 e2 e1val e2val b
| Or (a, b) -> eval e1 e2 e1val e2val a || eval e1 e2 e1val e2val b
| Var a -> if a = e1 then e1val else e2val
| Not a -> not (eval e1 e2 e1val e2val a) in
[(true, true, eval e1 e2 true true expr);
 (true, false, eval e1 e2 true false expr);
 (false, true, eval e1 e2 false true expr);
 (false, false, eval e1 e2 false false expr);];;

Truth tables for logical expressions. (medium)

let table vars expr =
let rec findfirst v def = function
| [] -> def
| (key, value) :: t -> if key = v then value else findfirst v def t
in
let rec eval values = function
| Var a -> findfirst a false values
| Not e -> not (eval values e)
| Or (a, b) -> eval values a || eval values b
| And (a, b) -> eval values a && eval values b
in
let rec aux acc values expr = function
| [] -> (List.rev values, eval values expr) :: acc
| h :: t -> aux (aux acc ((h, false) :: values) expr t) ((h, true) :: values) expr t
in
aux [] [] expr vars;;

Gray code. (medium)

let gray bits =
let rec aux bits prefix parity =
if bits = 0 then [prefix] else
if parity = true then (aux (bits-1) (prefix ^ "1") false) @ (aux (bits-1) (prefix ^ "0") true) else
(aux (bits-1) (prefix ^ "0") false) @ (aux (bits-1) (prefix ^ "1") (true)) in
aux bits "" false;;

Huffman code (hard)

let huffman fs =
let freqof = function
| Leaf (f, _) -> f
| Branch (f, _, _) -> f in
let rec insert v = function
| [] -> [v]
| hd :: tl as orig -> if freqof hd >= freqof v then v :: orig else hd :: insert v tl in
let rec encode = function
| [] | [_] as orig -> orig
| h1 :: h2 :: tl -> encode (insert (Branch (freqof h1 + freqof h2, h1, h2)) tl) in
let encoded = encode (List.map ~f:(fun (v, f) -> Leaf (f, v)) (List.sort ~cmp:(fun (v1, f1) (v2, f2) -> if f1 = f2 then 0 else if f1 < f2 then -1 else 1) fs)) in
let rec develop acc prefix = function
| Leaf (_, a) -> (a, prefix) :: acc
| Branch (_, a, b) -> develop (develop acc (prefix ^ "1") b) (prefix ^ "0") a in
match encoded with
| [a] -> develop [] "" a
| [] | _::_ -> [];;