IMPLEMENTATION MODULE BitmapOperations;

(* Known bug - on the compare, all of the last set should not be compared *)

(* Bitmap operations using dynamic memory, see the corresponding definition *)
(* J. Andrea, May.18/92 -dos version *)
(* V1.0, J. Andrea, Mar.18/92 *)
(* This code may be freely used and distributed, it may not be sold. *)

(*
* A bitmap is implemented as a collection of BITSETS, each bit in the set is
* accessed as required by calculating the memory offset to the bitset containing
* the requested bit, then the offset into that bitset to get the specific bit.
* The global operations (Clear, And, Or, etc.) are performed not one bit at a
* time, but on one BITSETS (16 bits) at a time.
* The single bit operations, Put and Get, must be performed on one bit.
*)

FROM SYSTEM IMPORT TSIZE, ADDRESS;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM ASCII IMPORT EOL;
FROM FileSystem IMPORT CreateFile, Close, WriteChar, File, Response;
FROM StringOperations IMPORT Length;

TYPE
  Bitmap = POINTER TO RECORD
             rows, cols :CARDINAL;   (* dimensions of the bitmap *)
             start      :ADDRESS;    (* memory address of the first item *)
             size       :CARDINAL;   (* actual size of the bitmap in bytes *)
             in_last    :CARDINAL;   (* number of bits used in last bitset *)
             sets       :CARDINAL;   (* number of bitsets *)
           END;

VAR
  adra, adrb, adrc     :POINTER TO BITSET;   (* generic pointers *)
  i, j, k, n           :CARDINAL;            (* generic counters *)
  which_set, which_bit :CARDINAL;
  empty, full          :BITSET;
  outf                 :File;
  digits               :ARRAY [0..9] OF CHAR;

  bset_bits, bset_bytes :CARDINAL;

(* ---------------------------------------------------- *)
PROCEDURE WriteLn;
BEGIN
  WriteChar( outf, EOL );
END WriteLn;

(* ---------------------------------------------------- *)
PROCEDURE WriteString( s :ARRAY OF CHAR );
VAR i, n :CARDINAL;
BEGIN
  n := Length( s );
  IF n > 0 THEN
    n := n - 1;
    FOR i := 0 TO n DO
      WriteChar( outf, s[i] );
    END;
  END;
END WriteString;

(* ---------------------------------------------------- *)
PROCEDURE WriteCard( x :CARDINAL );
VAR y :CARDINAL;
BEGIN
  IF x < 10 THEN
    WriteChar( outf, digits[x] );
  ELSE
    y := x DIV 10;
    WriteCard( y );
    WriteCard( x - y * 10 );
  END;
END WriteCard;

(* -------------------------------------------------------- *)
PROCEDURE InRange( a :Bitmap; row, col :CARDINAL ) :BOOLEAN;
(* is the specified row/col item in this bitmap *)
BEGIN
  RETURN ( row >= 1 ) & ( row <= a^.rows ) & ( col >= 1 ) & ( col <= a^.cols );
END InRange;

(* -------------------------------------------------------- *)
PROCEDURE Offset( a :Bitmap; row, col :CARDINAL; VAR set, bit :CARDINAL );
(* calculate the memory offset to the row/col item from the first item *)
VAR which_dot :CARDINAL;
BEGIN

  (* the bitmap is treated as a long string of bits *)
  (* with one row laid after another                *)
  (* calculate the position of this dot             *)
  (* subtract the extra 1 here rather than twice later *)

  which_dot := ( row - 1 ) * a^.cols + col - 1;

  (* the bits are grouped into sets of 32 (imp. dep.) each *)
  (* calculate which set this dot belongs to   *)
  (* - this is an offset from the first, so it should be zero based *)

  set := which_dot DIV bset_bits;

  (* and how far into this set is the dot that we need *)

  bit := which_dot - set * bset_bits;

END Offset;

(* -------------------------------------------------------- *)
PROCEDURE ReverseOffset( a :Bitmap; set, bit :CARDINAL; VAR row, col :CARDINAL );
(* given item position, calculate row and column *)
VAR which_dot :CARDINAL;
BEGIN
  which_dot := ( set - 1 ) * bset_bits + bit;
  row       := 1 + ( which_dot DIV a^.cols );
  col       := which_dot - ( ( row - 1 ) * a^.cols );
END ReverseOffset;

(* ------------------------------------------------------- *)
PROCEDURE Build( VAR a :Bitmap; n_rows, n_columns :CARDINAL );
VAR n_bits :CARDINAL;
BEGIN
  NEW( a );

  (* protect users from themselves *)
  IF n_rows    = 0 THEN n_rows := 1 END;
  IF n_columns = 0 THEN n_columns := 1 END;


  a^.rows := n_rows;
  a^.cols := n_columns;

  n_bits  := n_rows * n_columns;

  a^.in_last := n_bits MOD bset_bits;

  IF a^.in_last = 0 THEN
    a^.in_last := bset_bits;       (* last one is filed *)
  ELSE
    (* must be a multiple of bits in a bitset *)
    n_bits := n_bits + bset_bits - a^.in_last;
  END;

  a^.sets := n_bits DIV bset_bits;   (* convert to bitsets *)
  a^.size := a^.sets * bset_bytes;   (* convert to bytes *)

  ALLOCATE( a^.start, a^.size );     (* grab that number of bytes from memory *)

END Build;

(* -------------------------------------------------------- *)
PROCEDURE Destroy( VAR a :Bitmap );
BEGIN
  DEALLOCATE( a^.start, a^.size );
  DISPOSE( a );
END Destroy;

(* -------------------------------------------------------- *)
PROCEDURE Put( a :Bitmap; row, col :CARDINAL; set :CARDINAL );
BEGIN
  IF InRange( a, row, col ) THEN
    Offset( a, row, col, which_set, which_bit );
    adra  := a^.start + which_set * bset_bytes;

    IF set = 0 THEN
      EXCL( adra^, which_bit );
    ELSIF set = 2 THEN
      IF which_bit IN adra^ THEN
        EXCL( adra^, which_bit );
      ELSE
        INCL( adra^, which_bit );
      END;
    ELSE
      INCL( adra^, which_bit );    (* everything else means turn on *)
    END;
  END;
END Put;

(* -------------------------------------------------------- *)
PROCEDURE Get( a :Bitmap; row, col :CARDINAL ) :BOOLEAN;
VAR value :BOOLEAN;
BEGIN
  IF InRange( a, row, col ) THEN
    Offset( a, row, col, which_set, which_bit );
    adra  := a^.start + which_set * bset_bytes;
    value := which_bit IN adra^;
  ELSE
    value := FALSE;
  END;
  RETURN value;
END Get;

(* -------------------------------------------------------- *)
PROCEDURE Size( a :Bitmap; VAR n_rows, n_cols :CARDINAL );
BEGIN
  n_rows := a^.rows;
  n_cols := a^.cols;
END Size;

(* -------------------------------------------------------- *)
PROCEDURE Compare( a, b :Bitmap ) :BOOLEAN;
VAR result :BOOLEAN;
BEGIN

  result := TRUE;

  IF ( a^.rows = b^.rows ) & ( a^.cols = b^.cols ) THEN

    i := 1;
    k := 0;
    WHILE result & ( i <= a^.sets ) DO
       adra   := a^.start + k;
       adrb   := b^.start + k;
       result := adra^ = adrb^;
       i      := i + 1;
       k      := k + bset_bytes;
    END;

  ELSE
    result := FALSE;
  END;

  RETURN result;

END Compare;

(* -------------------------------------------------------- *)
PROCEDURE Clear( a :Bitmap );
BEGIN

  k := 0;
  FOR i := 1 TO a^.sets DO
     adra  := a^.start + k;
     adra^ := empty;
     k     := k + bset_bytes;
  END;

END Clear;

(* -------------------------------------------------------- *)
PROCEDURE Copy( a :Bitmap; VAR b :Bitmap );
BEGIN

  Build( b, a^.rows, a^.cols );

  k := 0;
  FOR i := 1 TO a^.sets DO
     adra  := a^.start + k;
     adrb  := b^.start + k;
     adrb^ := adra^;
     k     := k + bset_bytes;
  END;

END Copy;

(* -------------------------------------------------------- *)
PROCEDURE Not( a :Bitmap; VAR b :Bitmap );
BEGIN

  Build( b, a^.rows, a^.cols );

  k := 0;
  FOR i := 1 TO a^.sets DO
     adra  := a^.start + k;
     adrb  := b^.start + k;
     adrb^ := adra^ / full;        (* a Xor with <all bits> *)
     k     := k + bset_bytes;
  END;

END Not;

(* -------------------------------------------------------- *)
PROCEDURE And( a, b :Bitmap; VAR c :Bitmap; VAR ok :BOOLEAN );
BEGIN

  IF ( a^.rows # b^.rows ) OR ( a^.cols # b^.cols ) THEN
    ok := FALSE;
  ELSE
    ok := TRUE;

    Build( c, a^.rows, a^.cols );

    k := 0;
    FOR i := 1 TO a^.sets DO
       adra  := a^.start + k;
       adrb  := b^.start + k;
       adrc  := c^.start + k;
       adrc^ := adra^ * adrb^;       (* set intersection *)
       k     := k + bset_bytes;
    END;

  END;

END And;

(* -------------------------------------------------------- *)
PROCEDURE Or( a, b :Bitmap; VAR c :Bitmap; VAR ok :BOOLEAN );
BEGIN

  IF ( a^.rows # b^.rows ) OR ( a^.cols # b^.cols ) THEN
    ok := FALSE;
  ELSE
    ok := TRUE;

    Build( c, a^.rows, a^.cols );

    k := 0;
    FOR i := 1 TO a^.sets DO
       adra  := a^.start + k;
       adrb  := b^.start + k;
       adrc  := c^.start + k;
       adrc^ := adra^ + adrb^;    (* set union *)
       k     := k + bset_bytes;
    END;

  END;

END Or;

(* -------------------------------------------------------- *)
PROCEDURE Xor( a, b :Bitmap; VAR c :Bitmap; VAR ok :BOOLEAN );
BEGIN

  IF ( a^.rows # b^.rows ) OR ( a^.cols # b^.cols ) THEN
    ok := FALSE;
  ELSE
    ok := TRUE;

    Build( c, a^.rows, a^.cols );

    k := 0;
    FOR i := 1 TO a^.sets DO
       adra  := a^.start + k;
       adrb  := b^.start + k;
       adrc  := c^.start + k;
       adrc^ := adra^ / adrb^;   (* symmetric set difference *)
       k     := k + bset_bytes;
    END;

  END;

END Xor;

(* -------------------------------------------------------- *)
PROCEDURE Line( a :Bitmap; row1, col1, row2, col2 :CARDINAL; set :CARDINAL );

VAR
  dr, dc, length, x, y :REAL;
  i, n                 :CARDINAL;

BEGIN
   IF InRange( a, row1, col1 ) & InRange( a, row2, col2 ) THEN

     dr := FLOAT( row2 ) - FLOAT( row1 );
     dc := FLOAT( col2 ) - FLOAT( col1 );

     IF ABS( dr ) > ABS( dc ) THEN
       length := ABS( dr );
     ELSE
       length := ABS( dc );
     END;

     n := TRUNC( length );
     IF n > 0 THEN

       dr := dr / length;
       dc := dc / length;

       x := FLOAT( col1 ) + 0.5;
       y := FLOAT( row1 ) + 0.5;
       
       FOR i := 1 TO n DO
          Put( a, TRUNC( y ), TRUNC( x ), set );
          x := x + dc;
          y := y + dr;
       END;

     END;

   END;
END Line;

(* -------------------------------------------------------- *)
PROCEDURE PrintText( a :Bitmap; filename :ARRAY OF CHAR; VAR ok :BOOLEAN );
VAR r, c :CARDINAL;
BEGIN

  CreateFile( outf, filename, 0 );

  IF outf.res = done THEN
    ok := TRUE;

    n := a^.cols;
    IF n > 132 THEN n := 132 END;      (* no wider than 132 characters *)

    i := 0;
    j := bset_bits;

    r := 1;
    WHILE r <= a^.rows DO

       c := 1;
       WHILE c <= a^.cols DO

          IF j >= bset_bits THEN
            (* jump to the next bitset *)
            i := i + 1;  j := 0;
            adra := a^.start + ( i - 1 ) * bset_bytes;
          END;

          IF c <= n THEN

            IF j IN adra^ THEN
              WriteChar( outf, '*' );
            ELSE
              WriteChar( outf, '.' );
            END;

          END;

          c := c + 1;
          j := j + 1;
       END;
       WriteLn;

       r := r + 1;
    END;

    Close( outf );

  ELSE
    ok := FALSE;
  END;

END PrintText;

(* -------------------------------------------------------- *)
PROCEDURE PrintSixel( a :Bitmap; filename :ARRAY OF CHAR; VAR ok :BOOLEAN );

CONST
   esc     = 33C;
   max_out = 800;
   blank   = 63;

VAR
   out_line           :ARRAY [1..max_out] OF CARDINAL;
   r1, r2, r, c, f, x :CARDINAL;

BEGIN
  CreateFile( outf, filename, 0 );

  IF outf.res = done THEN
    ok := TRUE;

    n  := a^.cols;
    IF n > max_out THEN n := max_out; END;

    WriteChar( outf, esc ); WriteString( 'P0q' ); (* into Sixel graphics mode *)

    r1 := 1;
    WHILE r1 <= a^.rows DO

      (* work in sets of 6 rows at a time *)
      r2 := r1 + 5;        IF r2 > a^.rows THEN r2 := a^.rows; END;

      FOR c := 1 TO n DO
         k := blank;
         f := 1;
         FOR r := r1 TO r2 DO
            IF Get( a, r, c ) THEN
              k := k + f;
            END;
            f := f * 2;
         END;
         out_line[c] := k;
      END;

      (* truncate trailing blanks *)
      j := n;
      WHILE ( j > 1 ) & ( out_line[j] = blank ) DO
        j := j - 1;
      END;

      WriteString( '??' );  (* spaces *)

      (* try to use repeat counts to reduce file space and print time *)

      c := 1;
      WHILE c <= j DO

         k := 0;
         x := out_line[c];
         i := c + 1;

         WHILE ( i <= j ) & ( x = out_line[i] ) DO
            k := k + 1;
            i := i + 1;
         END;

         k := k + 1;   (* first + number of repeats *)

         (* determine if its repeated enough *)

         IF k > 3 THEN
           WriteChar( outf, '!' );
           WriteCard( k );
           WriteChar( outf, CHR( x ) );
         ELSE
           FOR i := 1 TO k DO
             WriteChar( outf, CHR( x ) );
           END;
         END;

         c := c + k;   (* jump ahead *)
      END;

      WriteString( '-' );  (* new graphics line *)

      r1 := r2 + 1;
    END;


    WriteChar( outf, esc ); WriteString( '\' );   (* out of Sixel mode *)

    Close( outf );
  ELSE
    ok := FALSE;
  END;

END PrintSixel;

(* -------------------------------------------------------- *)
PROCEDURE PrintPS( a :Bitmap; filename :ARRAY OF CHAR; size :CARDINAL;
                   VAR ok :BOOLEAN );

CONST
   max_rows = 750;
   max_cols = 560;
   side     = 25;

VAR
   r, c :CARDINAL;

   (* ------------- *)
   PROCEDURE WriteDot;
   BEGIN
      IF ( r * size < max_rows ) & ( c * size < max_cols ) THEN
        WriteCard( c ); WriteString( ' ' );
        WriteCard( r ); WriteString( ' D' ); WriteLn;
      END;
   END WriteDot;

BEGIN

  CreateFile( outf, filename, 0 );

  IF outf.res = done THEN
    ok := TRUE;

    IF size < 1 THEN
      size := 1;
    ELSE
      IF size > 100 THEN
        size := 100;
      END;
    END;

    WriteString( '%!PS-Adobe' ); WriteLn;
    WriteString( '/D { moveto ' );
    WriteString( ' 1 0 rlineto 0 1 rlineto -1 0 rlineto closepath fill' );
    WriteString( ' } bind def' ); WriteLn;

    WriteCard( side ); WriteString( ' ' ); WriteCard( max_rows );
    WriteString( ' translate 0 0 moveto' ); WriteLn;
    WriteString( '.2 setgray' ); WriteLn;
    WriteCard( size ); WriteString( ' dup neg scale' ); WriteLn;

    k := 0;
    FOR i := 1 TO a^.sets - 1 DO
       adra := a^.start + k;
       IF adra^ # empty THEN
         FOR j := 0 TO bset_bits DO
            IF j IN adra^ THEN
              ReverseOffset( a, i, j, r, c );
              WriteDot;
            END;
         END;
       END;
       k := k + bset_bytes;
    END;

    adra := a^.start + k;
    ReverseOffset( a, a^.sets, 0, r, c );
    FOR j := 0 TO a^.in_last - 1 DO
       IF j IN adra^ THEN
         WriteDot;
       END;
       c := c + 1;
    END;

    WriteString( 'showpage' ); WriteLn;
    WriteString( '%eof' );

    Close( outf );
  ELSE
    ok := FALSE;
  END;

END PrintPS;

BEGIN

  bset_bytes := TSIZE( BITSET );
  bset_bits  := bset_bytes * 8;

  empty := {};

  full := {};
  FOR i := 0 TO bset_bits - 1 DO
     INCL( full, i );
  END;

  FOR i := 0 TO 9 DO
     digits[i] := CHR( i + 48 );
  END;

END BitmapOperations.