Objects, dynamic cast, Obj.magic abuse and dragons

[Berke Durak <berke.durak@exalead.com>]

[-- Attachment #1: Type: text/plain, Size: 1727 bytes --]

Hello,

It seems that objects are back in fashion again on the list.

As records of functions or functors dont quite cut the mustard for some applications, I decided to give Ocaml's object 
system another try.  I tried to implement a conventional text adventure using those, of the "go north take sword kill 
dragon" kind.  Actually I had one such small prototype I wrote while learning Java, so I decided to port that one.

I've stumbled on a situation where I feel dynamic casting could be useful.  At least, that is the way I did it in the 
Java version.  I've worked around it using Obj.magic, but I can't check the class, so this could lead to nastiness.
I'd rather eat a runtime Class_cast_exception than a segmentation fault.

In this adventure, things can contain other things; a class physical has a list of things it contains, and an optional 
pointer to its container.

Persons, places and objects are things so they inherit from physical.  Hence, a forest is a place that can contain
a sword (an object), a dragon (a person) or another place (a small house).  Persons can be contained in places
or things (coffins).

The problem is that the main game loop gets the current location by taking the container of the hero... which is a 
physical.  However, it needs to call the place-specific method "go".

I'm submitting my example so that you can propose alternative solutions.  A few ideas:

* Add a go method in physical, raise an exception - not scalable, if I want to add other categories of things,
I'll have to add the corresponding method to physical.
* Parametrize physical with the type of contents.
* Use a sum type; but then it wouldn't be an object any more, and it's a centralized place.
-- 
Berke DURAK

[-- Attachment #2: adventure.ml --]
[-- Type: text/plain, Size: 5102 bytes --]

(* 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