(* Adventure *)

exception QuitException

let mandatory = function
  | None -> raise Not_found
  | Some x -> x

let pf = Printf.printf

let split_at c u =
  let m = String.length u in
  let b = Buffer.create m in
  let rec loop0 r i =
    if i >= m then
      List.rev r
    else
      if u.[i] = c then
        loop0 r (i + 1)
      else
        loop1 r i
  and loop1 r i =
    if i = m or u.[i] = c then
      begin
        let x = Buffer.contents b in
        Buffer.clear b;
        loop0 (x::r) (i + 1)
      end
    else
      begin
        Buffer.add_char b u.[i];
        loop1 r (i + 1)
      end
  in
  loop0 [] 0

let ( & ) f x = f x

class ['subject] io in_channel () =
  object
    val mutable subject : 'subject option = None
    method set_subject s = subject <- Some s
    method get_subject = mandatory subject
    
    method read =
      pf "< %!";
      split_at ' ' & input_line in_channel

    method write u =
      pf ">>> %s\n%!" u
  end

class virtual command =
  object
    method virtual get_verb : string
    method virtual perform : string list -> unit
  end

class virtual describable =
  object
    method virtual describe : 'a . 'a io -> unit
    method virtual get_name : string
  end

class virtual physical =
  object(self)
    inherit describable as super
    val mass = 1.0
    val takeable = true
    val mutable contents : physical list = []
    val mutable container : physical option = None
    method contents = contents
    method container = mandatory container

    method add : physical -> unit = fun thing -> contents <- thing :: contents

    method remove (thing : physical) = contents <- List.filter ((<>) thing) contents

    method unlink =
      match container with
      | None -> ()
      | Some t -> t#remove (self :> physical)

    method put (target : physical) =
      self#unlink;
      container <- Some target;
      target#add (self :> physical)
      
  end

class biscuit =
  object
    inherit physical as super
    method describe io =
      io#write "A square biscuit with chocolate in it.  It is organic, or at least that's what the writing on it, presumably in edible, organic ink, says.";
    method get_name = "a chocolate biscuit"
    method to_string = "the biscuit"
  end

type direction = N | S | E | W

let invert = function
| N -> S
| S -> N
| E -> W
| W -> E

let connect p1 d p2 =
  p1#connect d p2;
  p2#connect (invert d) p1

class virtual place =
  object(self)
    inherit physical as super
    val mutable seen = false
    val mutable outlinks : (direction * place) list = []

    method go d = List.assoc d outlinks

    method connect d t = outlinks <- (d, t) :: outlinks

    method describe_items : 'a . 'a io -> unit = fun io ->
      io#write "You can see:";
      List.iter
        (fun p ->
          let (q : physical) = p in
          q#describe io
        )
        contents

    method virtual describe_place : 'a . 'a io -> unit

    method describe io =
      self#describe_place io;
      self#describe_items io
  end

class virtual person =
  object
    inherit physical as super
    val takeable = false
  end

class hero =
  object
    inherit person as super
    method get_name = "John"
    method describe io = io#write "John is a tall man."
  end

let sf = Printf.sprintf

class forest name () =
  object(self)
    inherit place as super
    method get_name = name
    method describe_place io =
      io#write (sf "You are in %s" self#get_name)
  end

class sword =
  object(self)
    inherit physical as super

    method describe io =
      io#write "A one-meter long, titanium alloy, gold-plated, emerald-incrusted, Dragon-repelling adventurer's heavy duty sword."

    method get_name = "A golden sword"
  end

class game io =
  let f1 = new forest "the big dark forest" () in
  let f2 = new forest "the small dark forest" () in
  let f3 = new forest "the small light forest" () in
  let f4 = new forest "the tropical forest" () in
  let h  = new hero in
  let _ = h#put (f1 :> physical) in
  let _ = connect f1 N f2 in
  let _ = connect f2 E f3 in
  let _ = connect f3 S f4 in
  let _ = connect f4 E f1 in
  let _ = io#set_subject h in
  let sw = new sword in
  let _ = sw#put (f1 :> physical) in
  let b = new biscuit in
  let _ = b#put (f4 :> physical) in
  object(self)
    method where =
      let wh' = h#container in
      (* XXXXXXXX here *)
      let wh : place = Obj.magic wh' in (* I'd like a dynamic cast here! *)
      (* XXXXXXXX *)
      (*let wh' = (h#container : physical <: place) in*)
      wh

    method go d =
      try
        let wh = self#where in
        let wh = wh#go d in
        h#put (wh : place :> physical)
      with
      | Not_found ->
          io#write "Can't go there"
      
    method run =
      let wh = self#where in
      wh#describe io;
      begin
        match io#read with
        | ["n"] -> self#go N
        | ["s"] -> self#go S
        | ["e"] -> self#go E
        | ["w"] -> self#go W
        | _ -> io#write "Wtf?"
      end
  end

let play () =
  let io = new io stdin () in
  let g = new game io in
  while true do
    g#run
  done