surreal number implementation from On Numbers and Games

snum.ml

type snum = snums * snums
and snums = Nil | Cons of (snum * snums)

let zero = (Nil, Nil)
let one = (Cons (zero, Nil), Nil)
let mone = (Nil, Cons (zero, Nil))
let half = (Cons (zero, Nil), Cons (one, Nil))
let two = (Cons (one, Nil), Nil)

let rec map f = function
  | Nil -> Nil
  | Cons (x, rest) -> Cons (f x, map f rest)

let rec fold_left f init = function
  | Nil -> init
  | Cons (x, rest) -> fold_left f (f init x) rest

let rec app x y = match x with
  | Nil -> y
  | Cons (a, rest) -> Cons (a, app rest y)

let rec member_if f = function
  | Nil -> false
  | Cons (a, rest) -> if f a then true else member_if f rest

let member x = member_if (fun a -> x = a)

let rec remove_if_all f = function
  | Nil -> Nil
  | Cons (a, rest) -> if f a rest then remove_if_all f rest else Cons (a, remove_if_all f rest)

let remove_dup = remove_if_all member

(* remove duplicates *)
let rec normalize (l, r) =
  let newl = map normalize l
  and newr = map normalize r
  in (remove_dup newl, remove_dup newr)

let rec geq (p, q) (r, s) =
  (fold_left (fun i x -> i & (gt x (r, s))) true q) &
    (fold_left (fun i x -> i & (gt (p, q) x)) true r)
and gt x y = (geq x y) & (not (geq y x))

let eq x y = (geq x y) & (geq y x)

(* leave only the greatest number in the left set and the least number in the right set *)
let rec simplify (l, r) =
  let newl = map simplify l
  and newr = map simplify r
  in
  let rec remove_less = function
    | Nil -> Nil
    | Cons (_, Nil) as w -> w
    | Cons (a, Cons (b, rest)) -> if geq a b then Cons (a, remove_less rest) else Cons (b, remove_less rest)
  and remove_greater = function
    | Nil -> Nil
    | Cons (_, Nil) as w -> w
    | Cons (a, Cons (b, rest)) -> if geq a b then Cons (b, remove_less rest) else Cons (a, remove_less rest)
  in (remove_less newl, remove_greater newr)

let rec minus x =
  let (p, q) = x in (map (fun a -> minus a) q, map (fun a -> minus a) p)

let rec add x y =
  let (p, q) = x and (r, s) = y in
  normalize
    (app (map (fun a -> add a y) p) (map (fun a -> add x a) r),
     app (map (fun a -> add a y) q) (map (fun a -> add x a) s))

let rec times x y =
  let (lx, rx) = x and (ly, ry) = y in
  normalize
    (app
       (fold_left (fun acc a -> app acc (map (fun b -> add (add (times a y) (times x b)) (minus (times a b))) ly)) Nil lx)
       (fold_left (fun acc a -> app acc (map (fun b -> add (add (times a y) (times x b)) (minus (times a b))) ry)) Nil rx),
     app
       (fold_left (fun acc a -> app acc (map (fun b -> add (add (times a y) (times x b)) (minus (times a b))) ry)) Nil lx)
       (fold_left (fun acc a -> app acc (map (fun b -> add (add (times a y) (times x b)) (minus (times a b))) ly)) Nil rx))

let rec div x n =
  let rec loc x y =
    let (lx, rx) = x and (ly, ry) = y in
    simplify
      (normalize
         (app
            (fold_left (fun acc a -> app acc (map (fun b -> loc (add one (times (add a (minus x)) b)) a) ly)) Nil rx)
            (fold_left (fun acc a -> app acc (map (fun b -> loc (add one (times (add a (minus x)) b)) a) ry)) Nil lx),
          app
            (fold_left (fun acc a -> app acc (map (fun b -> loc (add one (times (add a (minus x)) b)) a) ly)) Nil lx)
            (fold_left (fun acc a -> app acc (map (fun b -> loc (add one (times (add a (minus x)) b)) a) ry)) Nil rx)))
  in
  match n with
  | 0 -> loc x (Cons (zero, Nil), Nil)
  | n' -> let (p, q) = div x (n' - 1) in
          let (s, r) = loc x (p, q) in
          simplify (normalize (app p s, app q r))

(* ad-hoc *)
let rec to_number x =
  let (l, r) = simplify x
  in
  match l with
  | Nil -> (
    match r with
    | Nil -> 0.0
    | Cons (b, _) -> if geq zero b then (to_number b) -. 1.0 else 0.0
  )
  | Cons (a, _) -> (
    match r with
    | Nil -> if geq a zero then (to_number a) +. 1.0 else 0.0
    | Cons (b, _) -> ((to_number a) +. (to_number b)) /. 2.0
  )

let rec count_nils (l, r) =
  let f = fold_left (fun acc x -> acc + (count_nils x)) 1
  in (f l) + (f r)