#
# $Id: langprocs.icn,v 1.2 2004/02/12 17:07:55 rparlett Exp $
#
# This file is in the public domain.
#
# Author: Robert Parlett (parlett@dial.pipex.com)
#

package lang

import util

#
# Return the class name for the instance o
#
procedure get_class_name(o)
   image(o) ? {
      if ="record " then {
         return tab(find("__state")) | stop("Not a class")
      }
   }
end

#
# Get the Class object for this object  
#
procedure get_class(object)
   return lang::get_class_for_name(get_class_name(object))
end

#
# Return the type of the object, as a string.  For standard Icon types,
# this is the value returned by the {type()} function.  For records, it
# is the string "record" and for classes it is the string "class".
#
procedure get_type(object) 
   image(object) ? {
      if ="record " then {
         if find("__state") then
            return "class"
         else
            return "record"
      } else
         return type(object)
   }
end

#
# Return the name of the object.  For a record this is the type name;
# for a class it is the class name, for a procedure the procedure name,
# for a file the filename and for a window the window name.  For all other
# types, this method fails.
#
procedure get_name(object)
   image(object) ? {
      if ="record " then {
         if s := tab(find("__state")) then
            return s
         else
            return type(object)
      } else if ="procedure " then
         return tab(0)
      else if ="file(" then
         return tab(-1)
      else if ="window_" then {
         tab(upto('('))
         move(1)
         return tab(-1)
      }
   }
end

#
# Return the id of the object, based on the string returned by {image()}.  For
# types that do not produce such a value, this method will have undefined
# results.
#
# @example
# @ x := [1, 2 ,3]
# @ write(image(x))
# @ write(get_id(x))
# @
# @ Output:
# @ list_5(3)
# @ 5
#
procedure get_id(object)
   image(object) ? {
      while tab(upto('_')) do 
         move(1)
      return tab(upto('('))
   }
end

#
# Generate the record names for a record.  The results are undefined for a
# non-record type of object.
#
procedure generate_record_names(object)
   every i := 1 to *object do {
      name(object[i]) ? {
         tab(upto('.'))
         move(1)
         suspend tab(0)
      }
   }
end

#
# Generate the member names for a class.  The results are undefined for a
# non-class object.
#
procedure generate_member_names(object)
   every name(object[3 to *object]) ? {
      tab(upto('.'))
      move(1)
      suspend tab(0)
   }
end

#
# Generate the members of a class.  The results are undefined for a
# non-class object.
#
procedure generate_class_members(object)
   suspend object[3 to *object]
end

#
# Return the {n}th member variable of a class.  The results are undefined for a
# non-class object.
#
procedure get_class_member(object, n)
   return object[3 + n]
end

#
# Cast the fields of this object to another object o.
#
procedure cast(object, other)
   local i, t

   t := table()
   i := 3
   every s := generate_member_names(other) do {
      t[s] := i
      i +:= 1
   }

   i := 3
   every s := generate_member_names(object) do {
      other[\t[s]] := object[i]
      i +:= 1
   }
   return other
end

#
# Succeed iff the given object is an instance of the class with the given name.
#
procedure is_instance(obj, name)
   return member(get_class_for_name(get_class_name(obj)).get_implemented_classes(), name)
end

#
# The default behaviour for Object.equals
#
procedure object_equals(obj, other, seen)
   local i

   /seen := table()
   /seen[obj] := set()
   insert(seen[obj], other)
   get_type(other) == "class" | fail
   get_name(obj) == get_name(other) | fail
   if *obj ~= *other then
      fail
   every i := 1 to *obj do
      equals(obj[i], other[i], seen) | fail
   return
end

#
# Compare this object with another by recursively comparing all
# members of the object.
#
procedure equals(x, y, seen)
   local cx, cy, i

   /seen := table()

   if member(\seen[x], y) then
      return

   if get_type(x) ~== get_type(y) then
      fail

   case get_type(x) of {
      "class" : {
         /seen[x] := set()
         insert(seen[x], y)

         #
         # If x subclasses Object, use its .equals method.
         #
         if is_instance(x, "lang__Object") then
            return x.equals(y, seen)
         else
            return object_equals(x, y, seen)
      }

      "record" : {
         /seen[x] := set()
         insert(seen[x], y)
         get_name(x) == get_name(y) | fail
         if *x ~= *y then
            fail
         every i := 1 to *x do
            equals(x[i], y[i], seen) | fail
         return
      }

      "list" : {
         /seen[x] := set()
         insert(seen[x], y)
         if *x ~= *y then
            fail
         every i := 1 to *x do
            equals(x[i], y[i], seen) | fail
         return
      }

      "set" : {
         /seen[x] := set()
         insert(seen[x], y)
         if *x ~= *y then
            fail
         return equals(sort(x), sort(y), seen)
      }

      "table" : {
         /seen[x] := set()
         insert(seen[x], y)
         equals(x[[]], y[[]]) | fail
         return equals(sort(x), sort(y), seen)
      }

      default : {
         if get_name(x) ~== get_name(y) then
            fail
         return x === y
      }
   }
end

procedure hash_string(s)
   local n
   n := *s
   every n +:= ord(!s \ 10)
   return n 
end

#
# The default behaviour for Object.hash_code
#
procedure object_hash_code(o, depth, seen)
   local n
   /seen := table()
   /depth := 3
   seen[o] := 1
   n := 0
   every n +:= hash_code(!o \ 10, depth - 1, seen)
   return n
end

#
# Return a hash code for this object.  For any two objects for which {equals} indicates
# equality, the returned hash code should be the same.
#
procedure hash_code(x, depth, seen)
   local cx, cy, i, n

   /seen := table()
   /depth := 3
   
   if (depth = 0) | \seen[x] then
      return 0
   
   n := 0

   case get_type(x) of {
      "class" : {
         seen[x] := 1
         if is_instance(x, "lang__Object") then
            return x.hash_code(depth, seen)
         else
            return object_hash_code(x, depth, seen)
      }

      "record" | "list" : {
         seen[x] := 1
         every n +:= hash_code(!x \ 10, depth - 1, seen)
      }

      "set" : {
         seen[x] := 1
         every n +:= hash_code(!sort(x) \ 10, depth - 1, seen)
      }

      "table" : {
         seen[x] := 1
         n +:= hash_code(x[[]], depth - 1, seen)
         every n +:= hash_code(!sort(x) \ 10, depth - 1, seen)
      }
      
      "string" :
         n +:= hash_string(x)
      
      "cset" :
         n +:= hash_string(string(x))

      "integer" :
         n +:= abs(x)

      "real" :
         n +:= hash_string(string(x))

      default :
         n +:= hash_string(get_name(x))
   }
   return n
end

#
# The default behaviour for Object.clone
#
procedure object_clone(o, seen)
   local res, i

   /seen := table()
   res := proc(get_name(o))()
   seen[o] := res
   every i := 1 to *o do
      res[i] := clone(o[i], seen)
   return res
end

#
# Clone the given object
#
procedure clone(o, seen)
   local c, e, ty, res, t

   /seen := table()

   if res := \seen[o] then
      return res

   ty := get_type(o)

   case ty of {
      "class" : {
         if is_instance(o, "lang__Object") then {
            t := o.clone(seen)
            seen[o] := t
            return t
         } else
            return object_clone(o, seen)
      }

      "record" : {
         res := proc(get_name(o))()
         seen[o] := res
         every i := 1 to *o do
            res[i] := clone(o[i], seen)
         return res
      }

      "set" : {
         res := set([])
         seen[o] := res
         every insert(res, clone(!o, seen))
         return res
      }

      "list" : {
         res := []
         seen[o] := res
         every put(res, clone(!o, seen))
         return res
      }

      "table" : {
         res := table(clone(o[[]], seen))
         seen[o] := res
         every e := !sort(o) do
            res[clone(e[1], seen)] := clone(e[2], seen)
         return res
      }

      default : 
         return o
   }
end

#
# The default behaviour for Object.to_string
#
procedure object_to_string(o, depth, seen)
   local i, s, string_buff

   /seen := table()
   /depth := -1
   seen[o] := 1
   string_buff := StringBuff()

   string_buff.add(get_type(o) || " " || get_name(o) || "<" || get_id(o) || ">")
   if depth ~= 0 then {
      string_buff.add("(")
      i := 3
      every s := generate_member_names(o) do {
         string_buff.add(s || "=")
         string_buff.add(to_string(o[i], depth - 1, seen))
         string_buff.add(";")
         i +:= 1
      }
      string_buff.drop_last(";")
      string_buff.add(")")
   }

   return string_buff.get_string()
end

#
# Convert the object to string ,descending structures to the given depth
#
# @param o       The object to be converted.
# @param depth   The depth of recursion; default is all levels
#
procedure to_string(o, depth, seen)
   local ty, string_buff

   /seen := table()
   /depth := -1

   if \seen[o] then {
      if s := get_name(o) then
         return "ref " || get_type(o) || " " || s || "<" || get_id(o) || ">"
      else
         return "ref " || get_type(o) || "<" || get_id(o) || ">"
   }

   string_buff := StringBuff()

   ty := get_type(o)

   case ty of {
      "record" : {
         seen[o] := 1
         string_buff.add(ty || " " || get_name(o) || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("(")
            i := 1
            every s := generate_record_names(o) do {
               string_buff.add(s || "=")
               string_buff.add(to_string(o[i], depth - 1, seen))
               string_buff.add(";")
               i +:= 1
            }
            string_buff.drop_last(";")
            string_buff.add(")")
         }
      }

      "class" : {
         seen[o] := 1

         if is_instance(o, "lang__Object") then
            string_buff.add(o.to_string(depth, seen))
         else 
            string_buff.add(object_to_string(o, depth, seen))
      }

      "procedure" :
         string_buff.add(ty || " " || get_name(o))

      "null" :
         string_buff.add("&null")
      
      "string" :
         string_buff.add("\"" || format_escape(o) || "\"")
      
      "cset" :
         string_buff.add("\'" || format_escape(o) || "\'")

      "integer" :
         string_buff.add(o)

      "real" :
         string_buff.add(o)

      "set" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("{")
            every e := !o do {
               string_buff.add(to_string(e, depth - 1, seen))
               string_buff.add(", ")
            }
            string_buff.drop_last(", ")
            string_buff.add("}")
         }
      }

      "list" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("[")
            every e := !o do {
               string_buff.add(to_string(e, depth - 1, seen))
               string_buff.add(", ")
            }
            string_buff.drop_last(", ")
            string_buff.add("]")
         }
      }

      "table" : {
         seen[o] := 1
         string_buff.add(ty || "<" || get_id(o) || ">")
         if depth ~= 0 then {
            string_buff.add("def=")
            string_buff.add(to_string(o[[]], depth - 1, seen))
            pairs := sort(o)
            string_buff.add("[")
            every e := !pairs do {
               string_buff.add(to_string(e[1], depth - 1, seen))
               string_buff.add("=")
               string_buff.add(to_string(e[2], depth - 1, seen))
               string_buff.add(";")
            }
            string_buff.drop_last(";")
            string_buff.add("]")
         }
      }

      "co-expression" : {
         string_buff.add(ty || "<" || get_id(o) || ">")
      }

      "file" : {
         string_buff.add(ty || "(" || get_name(o) || ")")
      }

      "window" : {
         string_buff.add(ty || "<" || get_id(o) || ">(" || get_name(o) || ")")
      }

      default : 
         string_buff.add("unknown type")
   }

   return string_buff.get_string()
end