#!/usr/bin/perl -w

# A list of objects and their links.

# usage: see gamfile.pm

# (c) Copyright by Tels 1999-2000. All Rights Reserved. Do NOT distribute.
# Updates and support on bloodgate.com/thief

# The bunch contains only a link to the OL. This means that 
# clone/translate/merge etc have to be duplicated. Some day I write a parent
# object Bag, which contains some thingies and their size/coordinates and can do
# the merge/clone/move stuff, and then use that as a template for brushes/objects
# whatever..

# 1999-11-04 v0.0.1 - from scratch
# 1999-11-16 v0.0.2 - revamped from Obj.pm, modified gamesys and bunch to use this
# 1999-12-17 v0.0.3 - stuff yourself back into VBR, copy etc
# 1999-12-25 v0.0.4 - fixed a couple of things, gen more stuff for objects
# 2000-01-07 v0.0.5 - finally got object stuff to work properly
# 2000-01-17 v0.0.6 - setproperty removes anything han a-z0-9 from property name
# 2000-02-13 v0.0.7 - fixed: rotate/rotateAll/translate
# 2000-03-10 v0.0.8 - added: object->{path}, findByPathName
#                     fixed: idByName
# 2000-04-08 v0.0.9 - added: fromBin, delete
#                     fixed: skip deleted objects
# 2000-05-26 v0.1.0 - added: lowest, highest, exists, setProperties 
#                     fixed: no longer global ID/count
# 2000-06-06 v0.1.1 - added: iterate gives additional params and "objects" as entitytype
# 2000-12-27 v0.1.2 - fixed: use strict

package Cowgen::ObjList;
require Exporter;
@ISA     = qw(Exporter);
@EXPORT  = qw(
             );
#@EXPORT_OK = qw();

use strict;

my $VERSION = 0.12;

#doc: create createObject idByName objectById getProperty setProperty 
#doc: objectAsText asText numObjects addLink delete
#doc: merge findByPathName 
#doc: iterate lowest highest exists setProperties

use Cowgen::Gamfile;
use Cowgen::Dromed;

sub create 
  { 
  # create new objectlist 
  # parameters: vbr (optional)
  my $c = shift; my $s = {}; bless $s, $c; 
  $s->init( @_ ); return $s;
  }

sub init
  {
  my $s = shift; 
  my $vbr = shift;
  $s->{lowest} = 0; $s->{highest} = 0;
  $s->{count} = "000";
  $s->{id} = 2; # start with 2 like DromEd
  $s->fromBin($vbr) if (defined $vbr);
  return $s;
  }

sub setProperty
  {
  # set a property of an object or archetype.
  # parameters: id (>0 => object; <0 => archetype), propertyname, array with values
  my $s = shift;
  my $id = shift;
  my $prop = lc(shift) || return;
  my @val = @_;
  my $o;
  $o = $s->{objects}->{$id};
  if (!defined $o)
    {
    print "ObList: Error: Tried setting property on unknown object '$id'.\n"; return;
    }
  $prop =~ s/.*\-\>//g;
  $prop =~ s/[^a-z0-9]//g; # remove spaces etc
  $o->{prop}->{$prop} = \@val;
  }

sub setProperties
  {
  # set a property of an object or archetype.
  # parameters: id (>0 => object; <0 => archetype), hash (with propertyname, ref to array 
  # with values)
  my $s = shift;
  my $id = shift;
  my $props = shift || return;
  my $o;
  foreach (keys %$props)
    {
    my $prop = lc($_);
    my $val = $props->{$_};
    $val = [ $val ] if (ref($val) ne 'ARRAY');
    $o = $s->{objects}->{$id};
    if (!defined $o)
      {
      print "ObList: Error: Tried setting property on unknown object '$id'.\n"; return;
      }
    $prop =~ s/.*\-\>//g;
    $prop =~ s/[^a-z0-9]//g; # remove spaces etc
    $o->{prop}->{$prop} = [ @$val ]; # make true copy
    }
  }

sub getProperty
  {
  # get a property of an object or archetype.
  # parameters: id (>0 => object; <0 => archetype), name, base
  my $s = shift;
  my $id = shift || return;
  my $prop = lc(shift) || return;
  $prop =~ s/.*\-\>//g;
  $prop =~ s/[^a-z0-9]//g; # remove spaces etc
  my $o = $s->{objects}->{$id};
  return $o->{prop}->{$prop} if (defined $o->{prop}->{$prop});
  return;
  }

sub addLink
  {
  # link two objects together
  # parameters: from, to, flavour, datalist
  my ($s,$from,$to,$fl,@data) = @_;
  print "Error: Objlist::addLink: Error: From-object does not exist ($from => $to with $fl\n"
   if (!defined $s->{objects}->{$from});
  if (($to >= 0) && (!defined $s->{objects}->{$to}))
    {
    print "Error: Objlist::addLink: Target object does not exist ($from => $to with $fl).\n";
    return;
    }
  my $link = {};
  $link->{from} = $from; 
  $link->{to} = $to; 
  $link->{fl} = $fl; 
  $link->{data} = \@data; 
  push @{$s->{objects}->{$from}->{links}}, $link;
  if (defined $s->{objects}->{$to})
    {
    my $blink = { to => $to, from => $from, fl => -$fl }; $blink->{data} = @data; 
    push @{$s->{objects}->{$to}->{links}}, $blink;
    }
  $link;
  }

sub createObject
  { 
  # Create new object based on "baseid" object. The new object will
  # get all the proper links and  properties as well as a uniqe id. 
  # Thus different routines can create objects at different times, and
  # as long as they use all the same ObjList object, all the objects
  # will be unique and properly linked. Care of the ids is taken when
  # mergin, cloning etc.
  # It is possible to create objects based on other objects rather than
  # archetypes, but I do think this will crash Dromed or the game engine
  # rather nicely.
  # parameters: x,y,z, w,l,h, namedparameters (base, name, rx,ry,rz etc)
  my ($s,$x,$y,$z,$w,$l,$h,$p) = @_;
  $p = {} if (!defined $p);
  print "ObjList.pm: Error: No object base archetype specified\n" if (!defined $p->{base}); 
  my $obj = copyHash($p); 
  # fix some stuff (missing r? and name) or use defaults
  my $n = $p->{name} || "object##num##"; 
  $n =~ s/##num##/"_".$s->{count}++/eg; 
  $obj->{id} = $s->{id};
  $obj->{time} = $s->{id};
  $obj->{prop} = { name => [ $n ] }; # properties
  $obj->{group} = 1; # default group
  $obj->{links} = []; # empty list
  $obj->{x} = $x || 0;  $obj->{y} = $y || 0; $obj->{z} = $z || 0;
  $obj->{rx} = $p->{rx} || 0; $obj->{ry} = $p->{ry} || 0; $obj->{rz} = $p->{rz} || 0;
  $obj->{path} = $p->{path} || "";   # path, for vworld stuff, makes re-finding objects easier
  # 0 means use physical dimensions
  $obj->{w} = abs($w || 0); $obj->{l} = abs($l || 0); $obj->{h} = abs($h || 0);
  my $id = $obj->{id};
  $s->{objects}->{$id} = $obj;
  # store lowest/highest ID
  # store lowest/highest ID
  $s->{lowest} = $id if ($id < $s->{lowest}); 
  $s->{highest} = $id if ($id < $s->{highest});
  $s->{id}++;
  return $id;
  }

sub addObject
  { 
  # (internal) add a object with a predifened ID. Used by fromBin/gamefile
  my ($s,$id) = @_;
  if (!defined $id)
    {
    print "Internal error: Objlist::addObject: Trying to add object with undefined ID.\n";
    }
  if (exists $s->{objects}->{$id})
    {
    print "Internal error: Objlist::addObject: Object already exists.\n";
    }
  my $obj = {};
  $obj->{id} = $id;
  $obj->{time} = $id;
  $obj->{prop} = { name => "" }; # properties
  $obj->{group} = 1; # default group
  $obj->{links} = []; # empty list
  $obj->{x} = 0; $obj->{y} = 0; $obj->{z} = 0;
  $obj->{rx} = 0; $obj->{ry} = 0; $obj->{rz} = 0;
  $obj->{w} = 0; $obj->{l} = 0; $obj->{h} = 0;
  $obj->{path} = '';
  $obj->{base} = 0;
  $s->{objects}->{$id} = $obj;
  # store lowest/highest ID
  $s->{lowest} = $id if ($id < $s->{lowest}); 
  $s->{highest} = $id if ($id < $s->{highest});
  return $id;
  }

sub lowest 
  {
  my $s = shift || return;
  return $s->{lowest};
  }

sub highest
  {
  my $s = shift || return;
  return $s->{highest};
  }

sub delete
  { 
  # mark an object as deleted
  my $s = shift || return;
  my $id = shift || return;
  my $o = $s->{objects}->{$id};
  if (defined $o) { $o->{deleted} = 1; return 1; }  
  return;
  }

sub setPosition
  {
  # set object center (x,y,z) and rotation rx,ry,rz
  my $s = shift;
  my $id = shift;
  return if (!exists $s->{objects}->{$id});
  my $o = $s->{objects}->{$id};
  ($o->{x},$o->{y},$o->{z},$o->{rx},$o->{ry},$o->{rz}) = @_;
  return $id;
  }

sub objectbyId
  {
  # return object by id, or undefined
  my $s = shift;
  my $id = shift || 0;
  return $s->{objects}->{$id} if (defined $s->{objects}->{$id});
  return;
  }

sub exists
  {
  # return 1 if object id exists
  my $s = shift;
  my $id = shift || 0;
  return exists $s->{objects}->{$id};
  }

sub idByName
  {
  # return object id by its name (is not necc. unique)
  my $s = shift;
  my $n = lc(shift) || "";
  foreach (keys %{$s->{objects}})
    {
    return $_ if (lc($s->{objects}->{$_}->{prop}->{name}->[0]) eq $n);
    }
  # not found, fuzzy search
  foreach (keys %{$s->{objects}})
    {
    return $_ if (lc($s->{objects}->{$_}->{prop}->{name}->[0]) =~ /$n/);
    }
  return 0;
  }

sub idByPathName
  {
  # return object id(s) by path/name (is not necc. unique and may
  # return more than one)
  # path/name is given like "world->upper->hallway->mystool", and
  # will be sep. into "world->upper->hallway" and "mystool", when
  # path AND name match, ID will be returned. Path and name can be 
  # regular expressions, so "bafford->.*->kitchen->(light|lamp)"
  # would return any light or lamp every of baffords kitchen(s).
  my $s = shift;
  my ($path) = lc(shift);
  my $name = $path; $name =~ s/.*\-\>//;
  $path =~ s/[^\-\>]*$//; $path =~ s/\-\>$//;
  my ($so,$w);
  wantarray ? $w = 1 : $w = 0;
  my @found;
  foreach (keys %{$s->{objects}})
    {
    $so = $s->{objects}->{$_};
    if ( ((lc($so->{prop}->{name}->[0]) =~ /$name/) || ($name eq '')) &&
         ((lc($so->{path}) =~ /$path/) || ($path eq '')) )
      {
      push @found, $_;
      last if ($w == 0);
      }
    }
  return wantarray ? @found : $found[0]; # return as list or single value
  }

sub objectAsText
  {
  # get all about one object/archeytpe (by ID), for debuggin
  my $s = shift; 
  my $id = shift || -1;
  my $indend = shift || "";
  my $flags = shift || 0;
  return "objectAsText: Object $id does not exist.\n" 
   if (!defined $s->{objects}->{$id});
  my $t = "";
  my $a = $s->{objects}->{$id};
  my ($fl,$fkey,@fkeys,$fk);
  $t .= "  Object {\n";
  $t .= "    Time\t= $a->{time}\n"; 
  $t .= "    Base\t= $a->{base}\n"; 
  $t .= "    Center\t= $a->{x}, $a->{y}, $a->{z}\n"; 
  $t .= "    Size\t= $a->{w}, $a->{l}, $a->{h}\n"; 
  $t .= "    Rotation\t= $a->{rx}, $a->{ry}, $a->{rz}\n"; 
  $t .= "    Group\t= $a->{group}\n"; 
  $t .= "    ID\t= $a->{id}\n"; 
#  $t .= " $_: $a->{$_}\n";
  $fl = $a->{links};
  foreach $fkey (@$fl)
    {
    $t .= "    Link {";
    @fkeys = sort keys %$fkey; 
    foreach $fk (@fkeys)  
      {
      $t .= "  $fk\t= $fkey->{$fk}";
      # if ($fkey->{$fk} ne 0);
      }
    $t .= "  }\n";
    } # end foreach link
  # properties
  $fl = $a->{prop}; my ($l,$e,$propname); 
  foreach $propname (keys %$fl)
    {
    $t .= "    $propname\t= ["; $l = '';
    foreach $e (@{$a->{prop}->{$propname}})  
      {
      $e =~ s/\"/\\\"/g; # protect quotas 
      $e = "\"$e\"" if (($e =~ /\s/) || ($e eq ""));
      $l .= " $e,";
      }
    $l =~ s/,$//; $t .= "$l ]\n";
    }
  $t .= "  } # Object\n\n" if ($flags == 1);
  $t .= "  }\n" if ($flags == 0);
  return $t;
  }

sub numObjects
  {
  my $s = shift || return;
  return scalar keys %{$s->{objects}};
  }

sub asText
  {
  # return myself as text
  my $s = shift;
  my $gf = shift;
  my $indend = shift || "";
  my $t = "";
  my $id;
  foreach $id (keys %{$s->{objects}})
    {
    next if ($s->{objects}->{$id}->{deleted});
    $t .= $s->objectAsText ($id,$gf,$indend);
    }
  $t;
  }

sub fip
  {
  return $_[0] / 2; # return for packing into float variable
  }

sub rot
  {
  return int($_[0] * 8192 / 45); # return number of ratation angle
  }

sub asBin
  {
  # stuff yourself into VBR and return object as brushlist, used by Bunch.pm
  # parameters: vbr, gamfile
  my $s = shift;
  my $vbr = shift;
  my $gf = shift;
  $s->add2Vbr($vbr,$gf);
  my $buffer = "";
  my ($a,$o,$b);
  foreach (keys %{$s->{objects}})
    {
    $o = $s->{objects}->{$_};
    next if ($o->{deleted});
    $b = pack ("SSLSCCffffffSSSSCCCCCCCCCCCCCCCCCCCCCCCCCCCCL",
      $o->{id},$o->{time},$o->{id},
      0,0xFD,0,
       $o->{x},$o->{y},$o->{z},
       fip($o->{l}),fip($o->{w}),fip($o->{h}),
       rot($o->{rz}),rot($o->{ry}),rot($o->{rx}),
       0xFFFF,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
       0,0,0,0,$o->{group},0);
    $buffer .= $b;
    }
  $buffer;
  }

sub fromBin
  {
  # create yourself from an VBR object
  # dont bother to look at brushlist, just decode metaproperty chunk to
  # find out which objects we all have and what there base is. Then decode
  # all the property chunks and attach them.
  my $s = shift;
  my $vbr = shift || return;  
  # take ObjVec chunk and from this info create all objects/archetypes
  my $ids = unpackObjVec($vbr);
  foreach (@$ids) { $s->addObject($_); }
  my $meta = unpackMetaProp($vbr);
  my ($id,$obj);
  # from meta properties base info create all the objects that are still missing
  # rooms etc
  foreach my $m (keys %$meta)
    {
    if ($meta->{$m}->{type} == 0)
      {
      $id = $meta->{$m}->{id};
      $s->addObject($id) if (!$s->exists($id));
      }
    }
  # now we have base (also all objects), we just add the normal metaproperties
  # and the objects bases
  foreach my $m (keys %$meta)
    {
    $obj = $s->{objects}->{$meta->{$m}->{id}};
    if (!defined $obj)
      {
      print "Objlist::fromBin: Error: Obj #$meta->{$m}->{id} not found.\n"; next;
      }
    if ($meta->{$m}->{type} != 0)
      {
      push @{$obj->{prop}->{metaproperty}}, $meta->{$m}->{base};
      }
    else
      { 
      $obj->{base} = $meta->{$m}->{base};
      }
    }
  # now decode properties and attach them
  decodeProperties($s,$vbr);
  # debug: lets see what we got
  #print $s->asText();
  return $s;
  }

sub add2Vbr
  {
  # take a list of objects and stuff the proper bin stuff into the vbr object
  # parameters: vbr, objlist, gf
  my $s = shift;
  my $vbr = shift || return;
  my $gf = shift || return;
  #$vbr->delChunk('OBJ_MAP');
  $gf->encodeLinks($s,$vbr);        # put links first
  $gf->encodeProperties ($s,$vbr);  # put properties as well as "LD?$MetaProp"
  }

sub merge
  {
  # merge another objlist into yourself (needed due to unique IDs and links
  # based on them). This is used by Bunch.pm
  my $s = shift || return;
  my $ol = shift || return;
  my ($cid,$clone,$links,$link,$newid,%oldones,%newones);
  my $id = 1;
  foreach $cid (keys %{$ol->{objects}})
    {
    next if ($ol->{objects}->{$cid}->{deleted});
    # for each object copy all but links and give new id, store old id
    #print "Merging $cid\n";
    $clone = {}; # empty one
    foreach my $key (keys %{$ol->{objects}->{$cid}})
      { 
      $clone->{$key} = $ol->{objects}->{$cid}->{$key} if ($key ne "links");
      #print " $key = $clone->{$key}\n";
      }
    $oldones{$clone->{id}} = $id; # map old <=> new
    $newones{$id} = $clone->{id}; # map old <=> new
    $clone->{id} = $cid; # create new id
    $s->{objects}->{$id} = $clone; # add object
    $id++; 
    }
  # now copy links and correct the ids
  my ($oldid,$l);
  foreach $cid (keys %{$s->{objects}})
    { 
    next if ($s->{objects}->{$cid}->{deleted});
    $oldid = $newones{$cid};
#    print "$newid\n";
    next unless defined $oldid;
    # for each new object correct links/backlinks
    $links = $ol->{objects}->{$oldid}->{links};
    foreach $link (@$links)
      {
      $l = {}; # new one
      $l->{fl} = $link->{fl}; 
      $l->{from} = $oldones{$link->{from}}; 
#      print "to: $l->{to} $link->{to} $link->{from} $link->{fl}\n";
      $l->{to} = $oldones{$link->{to}} || $link->{to};  # || for archetypes
      $l->{data} = [];
      foreach (@{$link->{data}})
        {    
        push (@{$l->{data}}, $_ );
        } 
#      print "original flavour $l->{fl} from $link->{from} to $link->{to}, now from $l->{from} to $l->{to}\n";
      push @{$s->{objects}->{$cid}->{links}}, $l;
      }
    }
  return $s;
  }

sub translate
  {
  # translate (move) all  objects
  # This is used by Bunch.pm.
  my $s = shift || return;
  my ($bid,$b,$tx,$ty,$tz) = @_;
  foreach $bid (keys %{$s->{objects}})
    {
    $b = $s->{objects}->{$bid};
    $b->{x} += $tx; $b->{y} += $ty; $b->{z} += $tz;
    }
  return $s;
  }

sub rotate
  {
  # rotate all objects
  # This is used by Bunch.pm.
  my $s = shift || return;
  my $ax = shift || 0; my $ay = shift || 0; my $az = shift || 0; # angle
  my $rx = shift || 0; my $ry = shift || 0; my $rz = shift || 0; # center
  my ($bid,$b,@c);
  foreach $bid (keys %{$s->{objects}})
    {
    $b = $s->{objects}->{$bid};
    @c = rotatePoint ($b->{x},$b->{y},$b->{z},$rx,$ry,$rz,$ax,$ay,$az);
    $b->{x} = $c[0]; $b->{y} = $c[1]; $b->{z} = $c[2];
    $b->{rx} += $ax; $b->{ry} += $ay; $b->{rz} += $az;
    clipAngle($b->{rx},$b->{ry},$b->{rz});
    }
  return $s;
  }

sub rotateAll
  {
  # rotate all objects around their center
  # This is used by Bunch.pm.
  my $s = shift || return;
  my $ax = shift || 0; my $ay = shift || 0; my $az = shift || 0; # angle
  my ($b,$bid);
  foreach $bid (keys %{$s->{objects}})
    {
    $b = $s->{objects}->{$bid};
    $b->{rx} += $ax; $b->{ry} += $ay; $b->{rz} += $az;
    clipAngle($b->{rx},$b->{ry},$b->{rz});
    }
  return $s;
  }

sub iterate
  {
  # walk list of objects and for each that matches the criteria(s), call 'call'
  # return undef for error, otherwise $self. caller is called with following
  # parameter list: olist, ref_to_entity (object)
  # named parameters: match (which property name should match what; hash of
  # name=>value etc), call (ref to sub to call)
  my $s = shift;
  my $p;
  if (ref($_[0]) ne 'HASH')
    {
    $p = { @_ };
    }
  else
    {
    $p = shift || return;
    }
  my $match = $p->{match} || {}; # default match all
  my $call = $p->{call} || sub { shift; printHash (shift);} ; # default print
  my @params = @{$p->{params} || []};
  my ($m,$id,$e);
  ENTITY:
  foreach $id (keys %{$s->{objects}})
    {
    $e = $s->{objects}->{$id};
    foreach $m (keys %$match)
      {
      next ENTITY if ($e->{$m} ne $match->{$m});
      }
    &{$call} ($s,$e,'objects',@params);
    }
  return $s;
  }
 
sub DESTROY
  {
  # no cleanup needed 
  # print "destroyed!\n";
  }

1;

