UNIT dynamic_set; {-*-Mode: fundamental-mode}
INTERFACE
uses base, dictionary;

(*--------------- token_set routines --------------------------------------------------------------------------*)
const
  set_elements = 255;  {runnung from 0..255}

type
  set_handle_t = pointer;

procedure set_make_empty  (var sh      : set_handle_t);                                               
procedure set_add_element (var sh      : set_handle_t; e       : dic_indx);                         
function  set_element_of  (   sh       : set_handle_t; e       : dic_indx)             : boolean;   
function  set_empty       (   sh       : set_handle_t)                                 : boolean;   
function  set_equal       (   sh1, sh2 : set_handle_t)                                 : boolean;   
procedure set_assign      (   sh1      : set_handle_t; var sh2 : set_handle_t); {sh2:= sh1}        
procedure set_union       (   sh1, sh2 : set_handle_t; var sh3 : set_handle_t); {sh3:= sh1 + sh2}  
procedure set_intersection(   sh1, sh2 : set_handle_t; var sh3 : set_handle_t); {sh3:= sh1 * sh2}  
procedure set_exclusion   (   sh1, sh2 : set_handle_t; var sh3 : set_handle_t); {sh3:= sh1 - sh2}  
procedure set_write       (   sh       : set_handle_t;    dh  : dic_handle_t);                    
(*--------------- token_set routines ------------ END ---------------------------------------------------------*)

IMPLEMENTATION
type
  token_rng_t   = 0..set_elements;                              {token range, low order part of token}
  token_set_t   = set of token_rng_t;                           {set of a token's low order bits}
  token_obj_t   = record   
                    token_set_low : token_set_t;                {low order set}
                    token_set_num : ShortInt;                   {high order part}
                  end;
  token_rec_p_t = ^token_rec_t;
  token_rec_t   = record                                        {dynamically expandable set list}
                    token_rec_next: token_rec_p_t;              {next}
                    token_obj     : token_obj_t;                {max of 32 contiguous tokens per control block} 
                  end;


procedure set_make_empty     (var sh: set_handle_t);
var p: token_rec_p_t; 
begin
  p:= sh; 
  if p=nil then new (p);
  with p^ do begin token_rec_next:= nil; with token_obj do begin token_set_low:= []; token_set_num:= 0 end end;
  sh:= p
end;

procedure set_add_element (var sh: set_handle_t; e: dic_indx);
var p: token_rec_p_t; 
begin
  p:= sh; 
  if p=nil then set_make_empty (p);
  with p^.token_obj do begin token_set_low:= token_set_low + [e] end;
  sh:= p
end; 

function  set_element_of  (sh: set_handle_t; e: dic_indx): boolean;
var p: token_rec_p_t;
begin
  p:= sh;
  if p=nil
    then set_element_of:=false
    else set_element_of:= e in p^.token_obj.token_set_low
end;

function set_empty     (sh: set_handle_t): boolean;
var p: token_rec_p_t;
begin
  p:= sh;
  if p=nil
    then set_empty:= true
    else set_empty:=p^.token_obj.token_set_low=[]
end; 

function set_equal     (sh1, sh2: set_handle_t): boolean;
var p1, p2: token_rec_p_t;
begin
  p1:= sh1;
  p2:= sh2;
  if (p1<>nil) and (p2<>nil)
    then set_equal:= p1^.token_obj.token_set_low  =   p2^.token_obj.token_set_low
    else set_equal:= set_empty (p1)              and  set_empty (p2)
end;

procedure set_assign (sh1: set_handle_t; var sh2: set_handle_t);
var p1, p2: token_rec_p_t;
begin
  if sh1<>sh2 then
    if set_empty (sh1)
      then set_make_empty (sh2)
      else
        begin
          set_make_empty (sh2); {mist}
          p1:= sh1;
          p2:= sh2;
          p2^.token_obj.token_set_low:= p1^.token_obj.token_set_low
        end;
end;

procedure set_union (sh1, sh2: set_handle_t; var sh3: set_handle_t);            {sh3:= sh1 + sh2}
var p1, p2, p3: token_rec_p_t; 
begin
  p1:= sh1; 
  p2:= sh2; 
  p3:= sh3; if p3=nil then set_make_empty (p3);
  if set_empty (p1)
    then if set_empty   (p2)
       then set_make_empty (p3)     {p1=[ ]  p2=[ ]}
       else set_assign  (p2, p3)    {p1=[ ]  p2=[e]}
    else if set_empty   (p2)
       then set_assign  (p1, p3)    {p1=[e]  p2=[ ]}
       else p3^.token_obj.token_set_low:= p1^.token_obj.token_set_low + p2^.token_obj.token_set_low;
  sh3:= p3                          {p1=[e]  p2=[e]}
end;

procedure set_intersection (sh1, sh2: set_handle_t; var sh3: set_handle_t);     {sh3:= sh1 * sh2}
var p1, p2, p3: token_rec_p_t; 
begin
  p1:= sh1; 
  p2:= sh2; 
  p3:= sh3; 
  if set_empty (p1) or set_empty (p2)
    then set_make_empty (p3) 
    else 
      begin
       if p3=nil then set_make_empty (p3);
       p3^.token_obj.token_set_low:= p1^.token_obj.token_set_low * p2^.token_obj.token_set_low
      end;
  sh3:= p3 
end;

procedure set_exclusion (sh1, sh2: set_handle_t; var sh3: set_handle_t);        {sh3:= sh1 - sh2}
var p1, p2, p3: token_rec_p_t;
begin
  p1:= sh1;
  p2:= sh2;
  p3:= sh3;
  if set_empty (p1)
    then set_make_empty (p3)
    else if not set_empty (p2) then
      begin
       if p3=nil then set_make_empty (p3);
       p3^.token_obj.token_set_low:= p1^.token_obj.token_set_low - p2^.token_obj.token_set_low
      end;
  sh3:= p3
end;

procedure set_write       (sh: set_handle_t; dh: dic_handle_t); {final dynamic version}
var op: token_rec_p_t; i: token_rng_t;
begin
  op:= sh;
  while op<>nil do with op^, token_obj do
    begin
      for i:= 0 to set_elements do if i in token_set_low then if dh=nil
        then write (' ',                   (token_set_num+1)*i:1)  {no dictionary available, write the index}
        else write (' ', dic_symbol (dh, (token_set_num+1)*i) );   {write the string found in dictionary by index}
      op:= token_rec_next                                          {bug: write is limited to one text line}
    end;
end;
(*--------------- token_set routines ------------ END -----------------------------------*)

END.