--******************************************************************************
--*                                                                            *
--*  File:        Lua_03.lua                            Revision:  1.0         *
--*                                                                            *
--*  Contents:    first experiments with tag-based (single) inheritance        *
--*                                                                            *
--*  Creation:    06.03.2002                   Last Modification:  06.03.2002  *
--*                                                                            *
--*  Platform:    IBM-compatible PC running Windows 98SE                       *
--*                                                                            *
--*  Environment: Lua 4.0, TkLua 4.0                                           *
--*                                                                            *
--*  Author:      Andreas Rozek           Phone:  ++49 (711) 6770682           *
--*               Kirschblütenweg 15      Fax:    -                            *
--*             D-70569 Stuttgart         EMail:  Andreas.Rozek@T-Online.De    *
--*               Germany                                                      *
--*                                                                            *
--*  URL:         http://www.Andreas-Rozek.de/                                 *
--*                                                                            *
--*  Copyright:   the software is published under the "GNU Lesser General Pub- *
--*               lic  License" (see "http://www.fsf.org/copyleft/lesser.html" *
--*               for additional information)                                  *
--*                                                                            *
--*  Comments:    (none)                                                       *
--*                                                                            *
--******************************************************************************

  dofile("Lua_02_Lib.lua");

--**** provide single inheritance for "objects" (rather than tables) ****

  Object = {};                 -- (global) "Object" starts the inheritance chain

  local ObjectTag = newtag();                -- gets an unique tag for "objects"
    local ObjectIndexer = function (Table,Index)
      local Prototype = rawget(Table,"_prototype");
      if (type(Prototype) == "table") then
        return Prototype[Index];    -- may fail if prototypes form a closed loop
      elseif (Prototype == nil) then
        return %Object[Index];-- doesn't loop since "Object" is not an "object"!
      else
        return nil;
      end;
    end;
  settagmethod(ObjectTag,"index",ObjectIndexer);       -- "installs" inheritance

  settag(Object,ObjectTag);-- makes "ObjectTag" accessible through "tag(Object)"
  Object._prototype = 0;       -- allows prototype chain traversals to terminate

--**** extend the built-in global "type"-function to handle "objects" ****

  local _type = type;                          -- preserve the built-in function

  function type (Candidate, ObjectSavvy)
    if (ObjectSavvy) then
      if (tag(Candidate) == %ObjectTag) then
        return "object";   -- assuming that only tables get this tag assigned to
      else
        return %_type(Candidate);
      end;
    else
      return %_type(Candidate);
    end;
  end;

--**** provide some basic methods (available for every "object") ****

  function Object:clone ()                               -- generic clone method
    local Result = {};
      for Key,Value in self do              -- copy all fields (even _prototype)
        Result[Key] = Value;
      end;

      settag(Result,tag(Object));      -- effectively makes 'Result' an "object"
    return Result;
  end;

  function Object:inheritsfrom (Candidate)
    if (self == Candidate) then return true; end;   -- stops prototype traversal

    if (type(Candidate) ~= "table") then return false; end;             -- oops!

    local Prototype = rawget(self,"_prototype");
    if (type(Prototype) == "table") then        -- only tables may be considered
      if (tag(Prototype) == %ObjectTag) then
        return Prototype:inheritsfrom (Candidate);         -- continue traversal
      else
        return (Candidate == Prototype);           -- prototype chain stops here
      end;
    elseif (Prototype == nil) then  -- "Object" may not be explicitly registered
      return (Candidate == %Object);
    else
      return false;
    end;
  end;
  Object.inheritsFrom = Object.inheritsfrom;       -- allow alternative spelling

  function Object:new (...)                             -- generic "constructor"
    local Result = {};
      if (type(arg[1]) == "table") then
        if (tag(arg[1]) == %ObjectTag) then          -- "objects" will be copied
          Result = arg[1]:clone();
        else             -- plain tables are taken themselves (common Lua habit)
          Result = arg[1];
        end;

        for i = 2,getn(arg) do   -- additional arguments represent list elements
          Result[i] = arg[i];
        end;
      else
        for i = 1,getn(arg) do              -- arguments represent list elements
          Result[i] = arg[i];
        end;
      end;

      if (Result._prototype == nil) then       -- allows prototypes to be preset
        if (self == Object) then
          Result._prototype = Object;
        else
          Result._prototype = self._prototype;-- binds 'Result' to its prototype
        end;
      end;

      settag(Result,tag(Object));      -- effectively makes 'Result' an "object"
    return Result;
  end;

--**** allow objects to be "invoked" (as a shortcut for their own constructors) ****

  local ObjectConstructor = function (Target,...)
    if ((type(Target) == "table") and (tag(Target) == tag(Object))) then
      local Constructor = rawget(Target,"new"); -- don't "inherit" constructors!
      if (type(Constructor) == "function") then
        tinsert(arg,1,Target);    -- since "Constructor" needs a "self" argument
        return call(Constructor,arg);
      else
        error("error: missing (or inappropriate) constructor");
      end;
    else
      error("error: trying to invoke a non-function value");
    end;
  end;

  settagmethod(ObjectTag,"function",ObjectConstructor);

--******************************************************************************
--*                                                                            *
--*             User - a simple class to represent a single "user"             *
--*                                                                            *
--******************************************************************************

  User = Object{firstName="(unknown)", lastName="(unknown)"};
--settag(User,tag(Object));                             -- "User" is an "object"

  function User:new (firstName, lastName)
    local Result = {};
      Result._prototype = User;               -- binds 'Result' to its prototype
      settag(Result,tag(Object));      -- effectively makes 'Result' an "object"

      Result.firstName = firstName;                  -- no argument checking yet
      Result.lastName  = lastName;
    return Result;
  end;

  function User:toString ()
    return self.lastName..", "..self.firstName;
  end;

--******************************************************************************
--*                                                                            *
--*             Group - a simple class to represent a "user group"             *
--*                                                                            *
--******************************************************************************

  Group = Object{
    _prototype = User,              -- a "Group" can be seen as a special "User"
    GroupName="(unknown)"
  };
--settag(Group,tag(Object));                           -- "Group" is an "object"

  function Group:new (GroupName, ...)
    local Result = {};
      Result._prototype = Group;              -- binds 'Result' to its prototype
      settag(Result,tag(Object));      -- effectively makes 'Result' an "object"

      Result.GroupName = GroupName;                  -- no argument checking yet

      for i = 1,getn(arg) do
        Result[i] = arg[i];
      end;
    return Result;
  end;

  function Group:toString ()
    local Result = self.GroupName.." [";
      local UserCount = getn(self);
      if (UserCount == 0) then
        Result = Result.."(empty)";
      else
        for i = 1,UserCount do
          Result = Result..self[i]:toString();
          if (i < UserCount) then Result = Result.."; "; end;
        end;
      end;
    return Result.."]";
  end;

--******************************************************************************
--*                                                                            *
--*                                main program                                *
--*                                                                            *
--******************************************************************************

  print();
  print("Lua_03 - first experiments with tag-based (single) inheritance");
  print();

  local firstUser  = User("Elena","Rozek");
  local secondUser = User("Andreas","Rozek");
  local Phantom    = User();
  local UserGroup  = Group("Rozek Family", firstUser, secondUser);

  print("firstUser  = ", firstUser);
  print("secondUser = ", secondUser);
  print("Phantom    = ", Phantom);
  print("UserGroup  = ", UserGroup);
  print();
  print("UserGroup:inheritsfrom(User)? ",  UserGroup:inheritsfrom(User));
  print("UserGroup:inheritsfrom(Object)? ",  UserGroup:inheritsfrom(Object));
  print();
  print("type(UserGroup) = ", type(UserGroup,1));
exit();