gistfile1.txt

type 'a once = 'a option ref;;

let notyet : unit -> 'a once = fun () -> ref None;;
let write : 'a once -> 'a -> unit = 
  fun o a -> match !o with
	     | None -> o := Some a
	     | _ -> failwith "can't overwrite"
let read : 'a once -> 'a option = fun o -> !o;;


(* 
  A spine tree looks like this:

            _____/ .....
           /     |
          /     /\
    _____/     /  \
   /     |    /    \
  |     /\   /\    /\
  *    *  * *  *  *  *

 *) 

type 'a spine = Spine of 'a tree once * 'a spine once
and 'a tree = Tip of 'a once | Bin of 'a tree once * 'a tree once

let rec pow a = function
  | 0 -> 1
  | 1 -> a
  | n -> let b = pow a (n / 2) in
	 b * b * (if n mod 2 = 0 then 1 else a);;

let fresh_tip : unit -> 'a tree = fun () -> Tip (notyet ());;
let fresh_bin : unit -> 'a tree = fun () -> Bin (notyet (), notyet ());;
let fresh_spine : unit -> 'a spine = fun () -> Spine (notyet (), notyet ());;

let force : (unit -> 'a) -> 'a once -> 'a = fun f o -> 
  match !o with 
    | None -> let a = f () in write o a; a
    | Some a -> a

(* Get the "tip" for a given index, given a complete tree *)
(* t: 
   n: number of elements in the tree
   i: relative index (0 is the leftmost index) 0 <= i < n *)
let rec get_tree : 'a tree once -> int -> int -> 'a once = fun t i n -> 
  let f = if n == 1 then fresh_tip else fresh_bin in
  let t' = force f t in
  match (t', i, n) with
  | (Tip(o), 0, 1) -> o
  | (Bin(l,r), _, _) -> 
     if i < (n/2) then
       get_tree l i (n/2) else
       get_tree r (i-n/2) (n/2)
  | _ -> failwith "error";;


(* tree test *)
let t : string tree once = notyet ();;
write (get_tree t 0 2) "hi";;
write (get_tree t 1 2) "hi";;

(* Get the "spine" for a given index *)
let get_spine : 'a spine once -> int -> 'a once = fun s i ->
  let rec _get : 'a spine once -> int -> int -> 'a once = fun s i n ->
    let Spine(t, s') = force fresh_spine s in
    if i < n then get_tree t i n
    else _get s' (i-n) (n*2)
  in _get s i 1

(* spine test *)
let t : string spine once = notyet ();;
write (get_spine t 0) "hi";;
write (get_spine t 100000000) "hi";;