Basic arithmetic operations implemented from scratch on unary and binary representations of natural numbers

Binary.ml

(* Arithmetic with Binary numbers (unsigned, arbitrary precision!) *)

type digit = Zero | One
type t = digit list

let rec eq a b =
  match a, b with
  | [], [] -> true
  | da :: a, db :: b when da = db -> eq a b
  | _ -> false

let add_digits a b c =
  match a, b, c with
  | One, One, One -> One, One
  | Zero, One, One
  | One, Zero, One
  | One, One, Zero -> One, Zero
  | One, Zero, Zero
  | Zero, One, Zero
  | Zero, Zero, One -> Zero, One
  | Zero, Zero, Zero -> Zero, Zero

let pad a b =
  let rec pad a b =
    match a, b with
    | a, [] -> [], List.map (fun _ -> Zero) a
    | [], b -> List.map (fun _ -> Zero) b, []
    | da :: a, db :: b -> pad a b
  in
  let pad_left, pad_right = pad a b in
  pad_left @ a, pad_right @ b

let add a b =
  let rec add a b =
    match a, b with
    | [], b -> Zero, b
    | a, [] -> Zero, a
    | da :: a, db :: b ->
        let dc, tail = add a b in
        let d1, d2 = add_digits da db dc in
        d1, d2 :: tail
  in
  let a, b = pad a b in
  match add a b with
  | Zero, x -> x
  | One, x -> One :: x

let rec shift_left x =
  match x with
  | [] -> []
  | [last] -> [last; Zero]
  | d :: x -> d :: shift_left x

let mul a b =
  let rec mul a =
    match a with
    | [] -> [], b
    | d :: a ->
        let res, shifted_b = mul a in
        let res =
          match d with
          | Zero -> res
          | One -> add shifted_b res
        in
        res, shift_left shifted_b
  in
  let res, _shifted_b = mul a in
  res

let print_digit = function
  | Zero -> print_char '0'
  | One -> print_char '1'

let rec print x =
  match x with
  | [] -> print_digit Zero
  | [d] -> print_digit d
  | d :: x -> print_digit d; print x

let zero = []
let one = [One]
let two = [One; Zero]
let three = [One; One]
let four = add two two
let five = add two three
let six = add three three
let six' = mul two three
let six_t = eq six six'
let fifteen = mul three five
let fifteen' = mul five three
let fifteen_t = eq fifteen fifteen'
let sixteen = add fifteen one
let sixteen' = mul four four
let sixteen_t = eq sixteen sixteen'

Unary.ml

(* Arithmetic with Peano numbers *)

type t = Zero
       | Succ of t

let rec eq a b =
  match a, b with
  | Zero, Zero -> true
  | Zero, _
  | _, Zero -> false
  | Succ a, Succ b -> eq a b

let rec gt a b =
  match a, b with
  | Zero, _ -> false
  | Succ a, Zero -> true
  | Succ a, Succ b -> gt a b

let rec add a b =
  match a, b with
  | Zero, x -> x
  | Succ a, b -> add a (Succ b)

let rec mul a b =
  match a with
  | Zero -> Zero
  | Succ Zero -> b
  | Succ a -> add b (mul a b)

let rec sub a b =
  match a, b with
  | a, Zero -> Some a
  | Zero, _ -> None
  | Succ a, Succ b -> sub a b

let rec divide a b =
  match b with
  | Zero -> raise Division_by_zero
  | _ ->
      match a with
      | Zero -> (Zero, Zero)
      | a ->
          match sub a b with
          | None -> (Zero, a)
          | Some a ->
              let res, rem = divide a b in
              (Succ res, rem)

let div a b =
  let res, _rem = divide a b in
  res

let rem a b =
  let _res, rem = divide a b in
  rem

let rec print = function
  | Zero -> print_char '0'
  | Succ x -> print_char 'S'; print x

let gcd a b =
  let rec gcd a b =
    match b with
    | Zero -> a
    | _ -> gcd b (rem a b)
  in
  let a, b =
    if gt a b then a, b
    else b, a
  in
  gcd a b

let zero = Zero
let one = Succ zero
let two = add one one
let three = add two one
let four = add two two
let eight = add four four
let sixty_four = mul eight eight
let ten = add eight two
let eleven =
  let six = div sixty_four ten in
  add (add six four) one
let eleven' = add eight three
let t = eq eleven eleven'

let two' = gcd (mul four three) (mul two eleven)
let t = eq two two'