#!/usr/bin/perl -w

# Contains routines to read/write .gam files and object system stuff

# usage: 

# use Gamfile;
# $sys = readGameSys();

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

# 1999-11-06 v0.0.1 - moved stuff from DromEd.pm
# 1999-11-09 v0.0.2 - added some link and object stuff (still not even alpha)
# 1999-11-18 v0.0.3 - genNames, genLinks, addObjects2Vbr (yippeah!), obj 
# 1999-12-25 v0.0.4 - genBases
# 2000-01-07 v0.0.5 - added ObjVec, scale, animlight, particleattachment etc
# 2000-01-18 v0.0.6 - added: generic obj properties, ASCIIZ properties
# 2000-01-27 v0.0.7 - added: metaproperties, more properties work now, isProperty
#                            object sizes
# 2000-02-05 v0.0.8 - added: unpackMetaProp
# 2000-02-26 v0.0.9 - added: some more object properties
# 2000-03-18 v0.1.0 - added: decodeProperties, numProperties
#                            properties, links
#                            genNames => encodeNames, genLinks => encodeLinks
#                     fixed: clear old links/properties before stuffing in new
# 2000-03-25 v0.1.1 - fixed: properties sorted by game version, unknown properties#
# 2000-04-02 v0.1.2 - fixed: archetypes are now a Objlist container (simplifies much)
# 2000-04-08 v0.1.3 - fixed: decodeNameChunk
# 2000-04-29 v0.1.4 - added: decodeLinks
# 2000-05-13 v0.1.5 - fixed: some properties/link flavours, act/react system
# 2000-05-26 v0.1.6 - fixed: decodeSchemata encodeSchemata
#                            write/readGamesys => write/readFile
#                            addVoice addArchetype archetypes decodeObjVec

package Cowgen::Gamfile;
require Exporter;
@ISA    = qw(Exporter);
@EXPORT = qw( 
            encodeNames encodeProperties decodeProperties encodeLinks 
            unpackMetaProp unpackObjVec
            decodePosition decodeLinks
            );
#@EXPORT_OK = qw();

#doc: create readGamesys writeFile flavour flavourName
#doc: setStyle getStyle
#doc: addArchetype archetypes
#doc: addObjects2Vbr obj isProperty archetypeName archetypeBase decodeObjVec

use Cowgen::Vbr;
use Cowgen::Dromed;  # for THIEF, SSHOCK2 etc
use Cowgen::Darkprop;
use strict 'vars';

my $properties = dark_properties();

my $VERSION = 0.15;

sub create 
  { 
  # create gamefile object from file
  # parameters: filename
  my $c = shift; my $sys = shift || "data/Dark.gam";  
  my $s = {}; bless $s, $c; $s->init($sys); 
  return $s; 
  }

sub init
  {
  my $s = shift; 
  $s->{style} = 1; 
  $s->readFile(shift);
  }

sub setStyle 
  { 
  # set the style to Thief/System Shock2 (latter not supported yet)
  # this is no longer required, since thief() is the default style and
  # style is currently unused, anyway
  my $s = shift; 
  $s->{style} = shift || thief(); 
  }

sub getStyle 
  {
  # get the style
  my $s = shift; 
  return $s->{style};
  }

sub flavour
  {
  # return link number from Name
  # parameters: flavourname
  my $s = shift; 
  my $name = shift || return 0;
  return $s->{relations}->{$name} if (defined $s->{relations}->{$name});
  # not found, try substring match 
  my $list = $s->{relations};
  foreach (keys %{$list})
    {
    return $s->{relations}->{$_} if ($_ =~ /$name/i);
    }
  return 0;
  }

sub flavourName
  {
  # return link name from number
  # parameters: flavournr
  my $s = shift; 
  my $nr = shift || 0;
  return $s->{flavours}->[$nr] || "unknown";
  }

sub readFile
  {
  # read a *.gam file and store it for later reference, used by create()
  my $s = shift; 
  my $n = shift || "dark.gam"; $s->{sysfile} = $n; 
  $s->{sys} = Cowgen::Vbr->create ($n); # easy isnt it?
  my $sys = $s->{sys}; # speed
  # now pull off the list of relations (link types)
  # suck out stuff, sounds easy 'nuff
  ($s->{relations}, $s->{flavours}) = genRelations($sys); 
  $s->{archetypes} = Cowgen::ObjList->create($sys);
  $s->decodeLinks($s->{sys},$s->{archetypes});
  $s->decodeSchemata(); 
  $s->decodeVoices();
  }

sub by_num
  {
  $b <=> $a;
  }

sub writeFile
  {
  # write things back to a gam file (put modified things back in) 
  # parameter: filename
  my $s = shift; 
  $s->{sysfile} = shift || $s->{sysfile}; # rename?
  $s->encodeSchemata();
  $s->{sys}->writeFile ($s->{sysfile}); # easy isnt it?
  }

sub genRelations
  {
  # suck relations from Vbr object and make list and array for reference
  my $vbr = shift || return; 
  my $r = {}; # empty one
  my ($ofs,$ol,$part,$name,$i,$c,$num);
  $part = $vbr->getChunk("Relations");
  return if (!defined $part);
  $ol = length($$part); $ofs = 24; $num = 1;
  my $rn = []; $rn->[0] = "";
  while ($ofs < $ol)
     { 
     $name = unpack ("Z32",substr($$part,$ofs,32)); $ofs += 32;
     $r->{$name} = $num; $rn->[$num] = $name; $num++;
    } # end Relations
  return ($r,$rn);  
  }

#############################################################################
# start schema stuff

sub decodeSchemata
  {
  # suck wavfiles (schemasamples) from Vbr and add them as property to archetypes
  my $s = shift || return;
  my ($ofs,$prior,$ol,$j,$id,$part,$name,$cnt,$waves,$len);
  $part = $s->{sys}->getChunk("SchSamp");
  return if (!defined $part);
  $ol = length($$part); $ofs = $s->{sys}->headerSize(); 
  my $ar = $s->{archetypes}; # speed
  while ($ofs < $ol)
    { 
    ($id,$cnt) = unpack ("lL",substr($$part,$ofs,8)); 
    $ofs += 8; $j = $cnt; $waves = {};
    while ($j > 0)
      {
      $len = unpack ("L",substr($$part,$ofs,4)); $ofs += 4;
      ($name,$prior) = unpack ("Z$len"."C",substr($$part,$ofs,$len+1)); 
      $ofs += $len+1;
      $waves->{$name} = $prior; 
      $j --;
      } 
    $ar->setProperty($id,"wavfiles",$waves);
    } # end for all schemas
  }

sub encodeSchemata
  {
  # pack the schematas back to internal vbr object's SchSamp chunk
  my $s = shift || return;
  my $r; my $ar = $s->{archetypes}->{objects};
  my $sch = "";
  foreach my $o (keys %$ar)
    {
    # gather all objects which have a "wavfiles" property  
    $r = $ar->{$o}->{prop}->{wavfiles};
    next unless (defined $r);
    $r = $r->[0]; # first element
    $sch .= pack ("lL", $o, scalar keys %$r); # store base, and count
    foreach (keys %$r)
      {
      $sch .= pack ("LZ".length($_)."C", length($_), $_, $r->{$_});
      }
    }
  $s->{sys}->putChunk("SchSamp",\$sch,1,0);
  }

sub decodeVoices
  {
  # go trough all archetypes and get the voice index form the voice index property
  my $s = shift || return;
  $s->{voices} = {};
  my $r; my $ar = $s->{archetypes}->{objects}; 
  foreach (keys %$ar)
    {
    $r = $ar->{$_}->{prop}->{voiceindex};
    next unless (defined $r);
    #print "$_ => $r->[0]\n";
    if (defined $s->{voices}->{$r->[0]})
      {
      print "Error: decodeVoices: Archetype $_ has voice index $r->[0], but $s->{voices}->{$r->[0]}";
      print "already has this voice index!\n";
      }
    else
      {
      $s->{voices}->{$r->[0]} = $_;
      }
    }
  }

sub addVoice
  {
  # parameters: name, base_archetype (or none for using "Voice")
  # return: new voice archetype ID (<=0)
  my $s = shift || return;
  my $name = shift || "UnnamedVoice";
  my $id = shift || $s->obj("Voice");
  return 0 if ($id == 0);
  $id = $s->addArchetype($id,$name);
  # find highest voice index
  my $max = 0; foreach (keys %{$s->{voices}}) { $max = $_ if ($_ > $max); }
  $max++; $s->{archetypes}->setProperty($id, "voiceindex", $max );
  $s->{voices}->{$max} = $id; # update voice index cache
  return $id;
  }

#############################################################################
# end schema/voice stuff

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

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

sub isProperty
  {
  # return 1 if property is known, otherwise 0
  # parameters: name, versions (list of version to look in, like THIEF, THEIF2, SSHOCK2, 
  # optional)
  my $s = shift;
  my $prop = lc(shift || "");
  $prop =~ s/.*\-\>//g;
  $prop =~ s/[^a-z0-9]//g; # remove spaces etc
  my @v = @_ || (THEIF2,SSHOCK2,THIEF);
  foreach (@v)
    {
    return 1 if (defined $properties->[$_]->{$prop});  
    }
  }

sub numProperties
  {
  # return number of known properties
  # parameters: none
  my $s = shift;
  my $c = 0;
  my %ke;
  foreach (THIEF2,SSHOCK2,THIEF)
    { 
    foreach my $k (keys %{$properties->[$_]})
      {
      $ke{$k} = 1; 
      }
    }
  return scalar keys %ke;
  }

sub encodeProperties
  {
  # internal use only, gen metaprop link chunk and data chunk, contaning all
  # objects and their base, gen all object properties
  # gen FromBrief chunk (what does this stand for?)
  # gen position chunk
  # parameter: objlist, vbr
  my $s = shift;
  my $ol = shift || return;
  my $vbr = shift || return;
  my $m = $s->flavour("MetaProp");
  $vbr->removeChunks('^P$');   # kill old property chuncks
  # format is: L (0x0011xxxx, xx is counting), L (object ID), L (archetype base id),
  # S (relation number of MetaProp)
  my $buff = "";
  my $data = "\x04\x00\x00\x00"; # ??
  my $brief = "";
  my $pos = "";
  my $objvec = pack ("ll",-6144,2048); # min, max, bitfield
  my (@ov,$o,$cnt,$byte,$bit,$c);
  my $chunks = {};  # for a more general and tidy list of chunks
  $ov[1024] = 0; # preexpand for speed
  for ($byte = 0; $byte < 1024; $byte++) { $ov[$byte] = 0; }
  $cnt = ($m << 20) + 0x00010001; # link ID
  my ($ob,$prop,@p,$propcnt,$l,$length,$t,$name,@re,$i,@p1,$pr);
  $propcnt = 0;
  my $version = $vbr->version();
  foreach $o (keys %{$ol->{objects}})
    {
    $ob = $ol->{objects}->{$o};
    next if $ob->{deleted};
    $buff .= pack ("LlLS", $cnt, $o, $ob->{base}, $m); 
    $data .= pack ("LL", $cnt, 0);
    if (defined $ob->{prop}->{metaproperty})
      {  
      foreach (@{$ob->{prop}->{metaproperty}})
        {
        #print "ADD meta $m $cnt $o $_\n";
        $buff .= pack ("LlLS", $cnt, $o, $_, $m); 
        $data .= pack ("LL",$cnt,0x0400);
        $cnt++;
        }
      }
    $brief .= pack ("lLL", $o, 4, 1);
    $pos .= pack ("lLffflSSS", $o, 0x16, $ob->{x},$ob->{y},$ob->{z}, -1, 
      rot($ob->{rx}),rot($ob->{ry}),rot($ob->{rz}));
    $byte = 768 + ($o >> 3); $bit = $o & 0x7; $ov[$byte] |= (1 << $bit);
#    print "ov: $o $byte $bit $ov[$byte] => ", (1 << $bit),"\n";
    foreach $prop (keys %{$ob->{prop}})
      { 
      next if ($prop =~ /metaproperty/);
      # current version or basic property
      $pr = $properties->[$version]->{$prop} || $properties->[0]->{$prop};
      if ((defined $pr) && ($pr ne ""))
        {
        @p = split /,/,$pr;
        if ($p[1] eq "S") 
          {
          $length = length($ob->{prop}->{$prop}->[0]);
          $chunks->{$prop} .= pack ("LLLZ".($length+1), $o, $length+5,$length+1,
           $ob->{prop}->{$prop}->[0]); 
          } 
        else
          { 
          if (defined $p[4]) # WHY UNDEFINED WARN for LIGHTCOLOR????? ARRRRRG
            {
            @p1 = @p; splice (@p1,0,4); undef @re;
            foreach (@p1) 
              {
              #debug:print "$prop\n" if ($_ =~ /^\D+$/);
              $t = $ob->{prop}->{$prop}->[$_] || 0;
              $t = 0 if ($_ == -1);
              $t = -1 if ($_ == -2);
              $t = -2-$_ if ($_ < -2);
              if ($t =~ /Assassin/)
                {
                print "huh $prop:\n"; 
                for (my $i = 0; $i < @{$ob->{prop}->{$prop}}; $i++) 
                  {
                  print "$i => $ob->{prop}->{$prop}->[$i]\n"; 
                  }
                }
              push @re, $t; 
              }
            $chunks->{$prop} .= pack ("LL".$p[1], $o, $p[2], @re); 
            }
          else
            {
            $chunks->{$prop} .= pack ("LL".$p[1], $o, $p[2], @{$ob->{prop}->{$prop}}); 
            }
          }
        $propcnt++;
        }
      else
        {
        print "\rWarning: gamfile.pm: Property $prop is unknown or not supported yet.\n";
        }
      }
    $cnt++;
    }
  $vbr->putChunk('L$MetaProp', \$buff, 0x2, 0x0);
  $vbr->putChunk('LD$MetaProp', \$data, 0x2, 0x0);
  $vbr->putChunk('P$Position', \$pos, 0x2, 0x00010016);
  $vbr->putChunk('P$FromBrief', \$brief, 0x4, 0x0);
  # last value seems to be length (except for some which are 0100xx or 0200xx!?)
  foreach (keys %$chunks)
    {
    @p = split (",",$properties->[$version]->{$_} || $properties->[0]->{$_}); 
    $name = substr($p[0],0,9);
    $l = $p[3] || $p[2]; 
    $vbr->putChunk('P$'.$name, \$chunks->{$_}, 0x2, $l);
#    print "put ",length($chunks->{$_})," bytes for $_ ($p[0])\n";
    }
  $objvec .= pack ("C1024", @ov);
  $vbr->putChunk('ObjVec', \$objvec, 0x0, 0x2);
  print "$propcnt properties.\n";
  }

sub decodeProperties
  {
  # internal use only, decode object properties from vbr object and add to an object list
  # for speed we should replace calls to addProperty/Position by stuffing data directly
  # into objectlist
  # parameter: objlist, vbr
  my $ol = shift || return;
  my $vbr = shift || return;
  my ($v,$n,$chunk,@chunks,$length,$ofs,@p,%propname,$unknown,$records,$i,@f,$oid,$prop,$pn);
  my ($m1,$m2,$found,@p1,@re,$j,$max);
  # build lookup for chunkname => property name
  foreach $v (THIEF,THIEF2,SSHOCK2)
    {
    foreach (keys %{$properties->[$v]} )
      {
      @p = split /,/,$properties->[$v]->{$_}; $n = $p[0];
      $n = substr($p[0],0,9) if (length($p[0])>9);
      $propname{$n} = $_;
      }
    }
  $unknown = 0; my $maxv = 0;
  @chunks = $vbr->getChunkList();
  my $hs = $vbr->headerSize(); 
  foreach (@chunks)
    {
    next if $_ !~ /^P\$/;
    next if $_ =~ /^P\$(Position|FromBrief)/;
    $n = $_; $n =~ s/^P\$//;
    $chunk = $vbr->getChunk($_);
    if (!defined $chunk)  
      {
      print "Gamefile::decodeProperties: Error! Cant get Chunk $n out of vbr object!\n"; 
      next;
      }
    $length = length($$chunk)-$hs;
    next if ($length == 0); # dont look at empty chunks
    if (!exists $propname{$n})
      {
      print "$n unknown!\n"; $unknown ++;
      }
    else
      {
      @p = unpack ("Z12LLL",substr($$chunk,0,$hs)); 
      $m1 = $p[2];
      $pn = $propname{$n}; $found = 0;
      # take best fitting one
      foreach $v (THIEF2,SSHOCK2,THIEF)
        {
        if (exists ($properties->[$v]->{$pn}))
          {
          @p = split /,/,$properties->[$v]->{$pn}; 
          $p[3] = $p[2] if (!defined $p[3]);
          #print "Testing $v for $pn ($m1,$p[0],$p[1],$p[2])\n";
          if ($p[3] == $m1)
            { 
            #print "Using $v for $pn\n";
            $maxv = $v if ($v >= $maxv); $found = 1; last; # found
            }
          }
        }
      if ($found == 0)
        {
        print "$pn has different chunk version!";
        print "\nContact Tels and report '$n,$m1,$p[3]'!\n";
        next;
        }
      # print "$pn:\n";
      if ($p[1] eq 'S')
        {
        decodeNameChunk($chunk,$pn,$ol,$vbr); next;
        }
      $p[2]+=8;
      $records = int($length/$p[2]);
      if (($records*$p[2]) != $length)
        {
        print "Gamfile::decodeProperties: Error: Chunk $n has odd number of bytes.\n";
        next;
        }
      $ofs = $vbr->headerSize();
      @p1 = @p; splice (@p1,0,4); 
      for ($i=0; $i < $records; $i++)
        {
        @f = unpack ("lL".$p[1],substr($$chunk,$ofs,$p[2])); $ofs += $p[2];        
        if (!defined $ol->objectbyId($f[0]))
          {
          print "Gamfile::decodeProperties: Error: Object $f[0] does not exist.\n";
          next;
          }
        $oid = $f[0]; splice (@f,0,2); @re = @f; 
        if (defined $p[4])  
          {
          undef @re; $j = 0; $max = 0; # reorder params to match output reordering
          print "\n$p[0] reorder:\n" if ((defined $f[7]) && ($f[7] =~ /Assass/));
          foreach (@p1) 
            {  
            print "$_ => ",($f[$j] || 0),"\n" if ((defined $f[7]) && ($f[7] =~ /Assass/));
            next if (($_ eq "") || ($_ < 0)); # dont reorder constants
            #debug:print "$prop\n" if ($_ =~ /^\D+$/);
            $re[$_] = $f[$j] || 0; $j++; $max = $_ if ($_ > $max);
            }
          # set undefineds to 0
          for ($j = 0; $j <= $max; $j++) { $re[$j] = 0 if (!defined $re[$j]); } 
          }
        #if ((defined $re[7]) && ($re[7] =~ /Assass/))
        #  {
        #  $j = 0; foreach (@re) 
        #    {
        #    print "$j => ",($_ || 0),"\n"; $j++;
        #    }
        #  }
        $prop++; $ol->setProperty ($oid,$pn,@re);
        }
      }
    #print "$n:\n"; #print " length: $length\n";
    }
  $vbr->version($maxv); # correct version based on what we found
  decodePosition($ol,$vbr);
  print "$prop properties.\n";
  print "Oups! $unknown property types are unknown to me. Please contact Tels!\n" 
   if ($unknown != 0);
  }

sub decodeNameChunk
  {
  # decode a chunk with variable length names (like symname, book etc)
  my $chunk = shift || return;
  my $prop = shift || return;
  my $ol = shift || return;
  my $vbr = shift || return;
  my $ofs = $vbr->headerSize(); # skip header
  my $l = length($$chunk);
  my ($li,@f,$name);
  while ($ofs < $l)
    {
    @f = unpack ('lLL',substr($$chunk,$ofs,12)); 
    $ofs += 12; # skip object id, record lenght and string length
    ($name) = unpack("Z$f[2]",substr($$chunk,$ofs,$f[2])); 
    $ofs += $f[2];
    $ol->setProperty ($f[0],$prop,$name);
    }
  }

# first l is for object ID, then follow the link data fields
# -1 => hardcoded 0

my $linkdata =
  {
  # not implemented yet:
  # aiawareness => "l,", 
  # aidefendobject => "l,", #
  # airetreatptdibs
  # aivantageptdibs
  # aiwatchobject
  # creatureattachement => "l,60",                      # L_NECK, L_ABDOMEN etc
  # nowpicking
  # receptron
  # reactparam
  # scriptcontact
  # tpathnext
  # whblock
  # whinflated
  
  # from ss2 
  teleport => "",         # used in Ops1.mis, apparently no data
  # although existing, these arent used in any of the ss2 OMs, so I dont know anything 
  # they are probably created/maintained on the fly
  clip => "",
  mutate => "",
  missspang => "",
  gunflash => "",
  organ => "",
  hitspang => "",
  armoreffect => "",
  projectile => "",

  # metaprop (is cared for automatically)
 
  # no data:
  aicurrentpatrol => "",
  aifleesource  => "",
  aifleeto  => "",
  aiinvest => "",
  aipatrol => "",
  aiptdibs => "",
  airangedweapon => "",
  controldevice => "",
  corpse => "",
  corpsepart => "",
  culpablefor => "",
  firerer => "",
  oldconversation => "",
  owns => "",
  physattach => "",
  playerfactory => "",
  population => "",
  renderflash => "",
  route => "",
  sounddescription => "",
  tpathinit => "",
  transmute => "",
  voicelink => "",
  weapon => "",

  aiattack => "lL,4",
  aicamera => "lZ32Z32Z32Z32,128",
  aiconversationactor => "lL,4",
  aidoor => "lL,4",
  aifleedest => "lLLl,12,-1,0,1",                      # first is always 0 !?
  aifollowobj => "lLLflflflll,40,-1,-1,0,1,2,3,4,5",   # first two are always 0 !?
  ainoflee => "lL,4",
  aiprojectile => "lLLLLfllLLL,52,"                    # ctype,cdata,tmethod,desire,delay,
   ."0,1,2,3,4,9,5,6,7,8,-1,-1,-1",                    # ammo, burst,accuracy,leads(B),launchjoint
  contains => "lL,4",
  currentweapon => "ll,4",                             # number
  flinderize => "lLfLfff,24",                          # count,impulse,scatter(bool),X,Y,Z
  frobproxy => "lL,4",                                 # L_NO_WORLD etc
  lock => "ll,4",                                      # !?
  tpath => "lfLLL,16",                                 # speed, pause, limt(bool), unknown
  voiceover => "lL,4",                                 # L_WORLD_HIGHLIGHT, L_PICK_UP
  particleattachement => "lLLLL,16",                   # L_OBJECT/L_VHOT etc,
  scriptparams => "lZ16,16",                           # string
  stimsensor => "lL,4",                                # !?

  # need something to maintain arsrc automatically from arsrcdesc (why did they split them oh woe me)
  #arsrc => "lLLL,12",                                  # ID of link arSrcDescription, ?, ?
  #arsrcdesc => "lLfLZ32LLLfZ16Z32,116",               # objectid,intensity,?(always2?),0,lc-flags,
                                                       # lc-period,lc-maxfirings,lc-intensityslope
                                                       # propagator
  flowcontact => "lLLLL,16",                           # !?

  # Thief II
  aitarget => "",
  owns => "",                                          

  aisuspiciouslink => "lL,4",
  aigunflash => "lLL,8",                               # vhot, (L_PROJECTILE_FLASH, L_RANDOM_BANK)
  hostobject => "lL,4",                                # param ?
  tpath => "lfLLL,16",                                 # speed, pause, pathlimit(BOOL), 0
  };

sub encodeLinks
  {
  # generate link chunk and stuff into VBR
  # parameter: objlist, vbr
  my $s = shift;
  my ($ol,$vbr) = @_;
  my ($o,$c,$cd,$fl,$li,$flname,$linkcnt,$l,$ofs); 
  my ($c1,@p,@f,$c2,$lid,$t,$p); $ofs = 0; $linkcnt = 0; my $datacnt = 0;
  print "Generating object system: ";
  $vbr->removeChunks('^LD?\$');   # kill old link chunck 
  foreach $flname (@{$s->{flavours}})
    {
    next if (!defined $flname); # array starts with 1!
    $fl = $s->flavour($flname);
    $c = 'L$'.$flname; $c = substr($c,0,11) if (length($c) > 11);
    $cd = 'LD$'.$flname; $cd = substr($cd,0,12) if (length($cd) > 12);
#    print " $c $cd\n"; 
    $c1 = ""; $c2 = ""; $li = 0;
    $flname =~ s/\s//g; $p = $linkdata->{lc($flname)};
    if ((defined $p) && ($p ne ""))
      {
      # print "$flname exists in database\n";
      @p = split /,/,$p; $c2 = pack ("L", $p[1]);
      }
    foreach $o (keys %{$ol->{objects}})
      {
      #print " links for $o:\n"; 
      next if $o->{deleted};
      next unless (defined $ol->{objects}->{$o}->{links});
      foreach $l (@{$ol->{objects}->{$o}->{links}}) 
        {
        next unless ( abs($l->{fl}) == $fl); 
        $lid = ($l->{fl} << 20) + 0x10000 + $li;
        # put only forward links
        if ($l->{fl} > 0)
          {
#          print " from $l->{from} to $l->{to} flavour $l->{fl} id: ", sprintf ("%x",$lid),"\n";
          $c1 .= pack ("lllS", $lid, $l->{from}, $l->{to}, $fl ); $linkcnt++; # link
          if ((defined $p) && ($p ne ""))
            {
            if (defined $p[2])
              {
              @f = @p; splice @f,0,2; 
              foreach (@f)
                {
                $t = 0 if ($_ == -1);
                $t = -1 if ($_ == -2);
                $t = -2-$_ if ($_ < -2);
                $t = $l->{data}->[$_] if ($_ >= 0);
                $_ = $t;
                }
              }
            else
              {
              @f = @{$l->{data}}; 
              #print "data:\n"; foreach (@f) { print "$_\n"; } print "\n";
              }
            $c2 .= pack ($p[0],$lid,@f); $datacnt++;
            }  
          }
#        else
#          {
#          print " back from $l->{to} to $l->{from} flavour $l->{fl} id: ", sprintf ("%x",$lid),"\n"; 
#          }
        $li ++;
        }
      }
   # print "put for $fl ",length($c2)," bytes\n" if (length($c2) != 0);
    $vbr->putChunk($c,\$c1,2,0) if ($c1 ne "");
    $vbr->putChunk($cd,\$c2,2,0) if ($c2 ne "");
    }
  print "$linkcnt links ($datacnt with data), ";
  }

sub decodeLinks
  {
  # gather all links and their data, stuff it into list of objects
  # parameters: gamefile, vbr, ol
  my $s = shift || return;
  my $vbr = shift || return;
  my $ol = shift || return;
  my %inv = $vbr->getINV();
  #my $f = $s->{flavours}; # array with flavour names
  #print "flavours: ",scalar @{$f}," ";
  my ($h,$hk,$kd,$l,$from,$to,$o,$oo,$d,$ld,@p,$fl,$fln,$p,$li,@data);
  my $links = 0; 
  foreach my $k (keys %inv)
    {
    next if ($k =~ /MetaProp/);
    if ($k =~ /^L\$/)
      {
      $h = $vbr->decodeChunk ($k,"lllS",14,0,0);
      if ((scalar keys %{$h}) > 0)
        {
        $kd = $k; $kd =~ s/^L\$/LD\$/; # link data
        @p = each (%$h); $fl = $p[1]->[3]; $fln = lc( $s->flavourName($fl) ); 
        $fln =~ s/\s//g; $p = $linkdata->{$fln}; 
        print "DecodeLinks: Huh? Flavour $fl is $fln to me! Wrong gamesys?\n" 
         if ($fln eq "unknown");
        print "DecodeLinks: Flavour $fln ($fl) not yet implemented, please contact Tels!\n"
         if (!defined $p);
        if ((defined $p) && ($p ne ""))
          {
          # decode data records to attach them
          @p = split /,/,$p;
          #print "$kd $p[0] $p[1]\n";
          $d = $vbr->decodeChunk ($kd,$p[0],$p[1]+4,0,4);
          #foreach (keys %$d) { print "$_ $d->{$_}\n"; }
          }
        $p = "" if (!defined $p); # define
        foreach $hk (keys %{$h})
          {
          $links ++; $l = $h->{$hk};
          undef @data;
          if (($p ne "") && (defined $d->{$hk}))
            {
            # attach data
            #print "attaching data $d->{$hk} $hk\n";
            @data = @{$d->{$hk}}; shift @data;
            }
          $ol->addLink ($l->[1], $l->[2], $l->[3], @data );
          }
        } 
      }
    }
  print "links: $links\n"; 
  }

sub unpackObjVec
  {
  # unpack objvec chunk and return ref to list with all found IDs
  use integer;
  my $vbr = shift || return;  
  my $ids = [];
  my $buf = $vbr->getChunk ('ObjVec') || return $ids;
  my $ofs = $vbr->headerSize(); my $len = length($$buf);
  my ($min,$max) = unpack("lL",substr($$buf,$ofs,8)); $ofs += 8;
  my ($byte,$mask,$i);
  $min -= 8;
  while ($ofs < $len)
    {
    $byte = unpack("C",substr($$buf,$ofs,1)); 
    $ofs++; $min += 8;
    next if ($byte == 0);
    if ($byte == 0xFF)
      {
      # all on, use 0..7
      for ($i=0;$i<8;$i++) { push @$ids,$min+$i; }
      }
    else
      { 
      $mask = 0x80; $i = 7;
      while ($mask != 0)
        {
        push @$ids, $min+$i if (($byte & $mask) != 0);
        $mask = $mask >> 1; $i--;
        }
      }
    }
  return $ids;
  }

sub unpackMetaProp
  {
  # unpack the metaproperty info (link+data)
  # parameters: vbr
  my $vbr = shift || return;
  my $buf = $vbr->getChunk ('L$MetaProp') || return;
  my $ofs = $vbr->headerSize(); my $meta = {}; my ($cnt,$id,$base);
  my $len = length($$buf);
  while ($ofs < $len)
    {
    ($cnt, $id, $base) = unpack ("Lll", substr($$buf,$ofs,12)); 
    $meta->{$cnt}->{id} = $id; $meta->{$cnt}->{base} = $base;
    $ofs += 14; # skip 2 bytes
    }
  $buf = $vbr->getChunk ('LD$MetaProp') || return;
  $ofs = 28;
  while ($ofs < length($$buf))
    {
    ($cnt, $id) = unpack ("LL", substr($$buf,$ofs,8)); 
    $meta->{$cnt}->{type} = $id; # id = 0 => base, 0x400 => metaproperty
    $ofs += 8;
    } 
  print "Decoded ",scalar keys %$meta," metaproperty links and ";
  $meta;
  }

sub decodePosition
  {
  # special position chunk
  # parameter: vbr, olist
  my $ol = shift || return;
  my $vbr = shift || return;
  my $ofs = $vbr->headerSize();
  my $chunk = $vbr->getChunk ('P$Position') || return 0;
  my $len = length($$chunk);
  my (@f,$oid); my $prop = 0;
  while ($ofs < $len)
    {
    @f = unpack ("lLffflSSS",substr($$chunk,$ofs,30)); $ofs += 30;
    if (!defined $ol->objectbyId($f[0]))
      {
      print "Gamfile::decodePosition: Error: Object $f[0] does not exist.\n";
      next;
      }
    $oid = $f[0]; splice (@f,0,2); splice (@f,3,1); $prop ++;
    $ol->setPosition ($oid,@f);
    }
  $prop;
  }

#############################################################################
# archetype stuff

sub obj
  {
  # return archetype id from name (or 0 for undefined)
  my $s = shift;
  my $n = lc(shift);
  return $s->{archetypes}->idByName($n);
  }

sub addArchetype
  {
  # add an archetype and return its id
  # parameter: base_archtype_id, name
  my $s = shift;
  my $base = shift || -1; # object
  my $name = shift || "unnamed_new_archetype"; 
  $base = $s->obj($base) if ($base =~ /[^0-9\-]/); # convert basename => baseid
  return unless $s->{archetypes}->exists($base);
  my $id = $s->{archetypes}->addObject($s->{archetypes}->lowest()-1);
  $s->{archetypes}->setProperties($id, { base => [ $base ], name => [ $name ] } );
  return $id;
  }

sub archetypeName
  {
  # return archetype name from id
  my $s = shift;
  my $id = shift;
  my $a = $s->{archetypes}->objectbyId($id);
  return $a->{prop}->{name}->[0] || "unknown";
  }

sub archetypeBase
  {
  # return archetypes base from id
  my $s = shift;
  my $id = shift;
  my $a = $s->{archetypes}->objectbyId($id);
  return $a->{base} || 0;
  }

sub archetypes
  {
  # return oblist that contains the archetyps (to modify/inspect them)
  my $s = shift;
  return $s->{archetypes};
  }

1;

