Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!ut-sally!husc6!necntc!ncoast!allbery
From: rcb@rti.UUCP (Randy Buckland)
Newsgroups: comp.sources.misc
Subject: VMS DVI preview (part 3 of 3)
Message-ID: <2809@ncoast.UUCP>
Date: Mon, 6-Jul-87 21:48:48 EDT
Article-I.D.: ncoast.2809
Posted: Mon Jul  6 21:48:48 1987
Date-Received: Fri, 10-Jul-87 01:29:04 EDT
Sender: allbery@ncoast.UUCP
Lines: 1682
Approved: allbery@ncoast.UUCP
X-Archive: comp.sources.misc/8707/


$ write sys$output "Creating [.src]dvi_translate_.ada"
$ create [.src]dvi_translate_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Dvi_translate						|--
--| Date:   12-JUN-1987							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Read and translate DVI commands into bitmap.		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    12-JUN-1987	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with dvi_def;
use  dvi_def;

package dvi_translate is

---------------------------------------------------------------------------
--|									|--
--| Routine definitions.						|--
--|									|--
---------------------------------------------------------------------------
procedure build_page (
    page : in page_ptr);

end;
$ eod
$ checksum [.src]dvi_translate_.ada
$ if checksum$checksum .nes. "1813187772" then write sys$output -
    "    ******Checksum error for file [.src]dvi_translate_.ada******"
$ write sys$output "Creating [.src]font.ada"
$ create [.src]font.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font							|--
--| Date:   30-OCT-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Display a font picture					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    30-OCT-1986	New file.					|--
--| rcb	    23-JUN-1987	Modify to use version 2 I/O code.		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with font_def, font_io, uis, text_io, cli, str, condition_handling, sys;
use  font_def, font_io, uis, text_io, cli, str, condition_handling, sys;

with starlet, system, tasking_services;
use  starlet, system, tasking_services;

procedure font is

---------------------------------------------------------------------------
--|									|--
--| Static variables.							|--
--|									|--
---------------------------------------------------------------------------
type terminator is (up, down, done);

term      : terminator;
term_chan : channel_type;
status    : cond_value_type;

chars : char_set;
char  : integer;

display : display_type;
window  : window_type;

x_mag : float;
y_mag : float;

font_file : d_string;

---------------------------------------------------------------------------
--|									|--
--| Get_command								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Command code.					|--
--|									|--
--| Description:    Get bytes from the terminal and see if they		|--
--|		    form a known command.				|--
--|									|--
---------------------------------------------------------------------------
procedure get_command (
    term : in out terminator) is

trash : integer;

function get_char
    return integer is

code   : integer := 0;
status : cond_value_type;

begin
    task_qiow (
	status => status,
	chan   => term_chan,
	func   => io_readvblk or io_m_noecho,
	p1     => to_unsigned_longword (code'address),
	p2     => 1);
    return code;
end;	

begin
    loop
	case get_char is
	    when 26 => term := done; exit;
	    when 27 =>
		case get_char is
		    when 91 =>
			case get_char is
			    when 65 => term := up;        exit;
			    when 66 => term := down;      exit;
			    when others => put_line ("Invalid command.");
			end case;
		    when others => put_line ("Invalid command.");
		end case;
	    when others => put_line ("Invalid command.");
	end case;
    end loop;
end;

---------------------------------------------------------------------------
--|									|--
--| Main program.							|--
--|									|--
---------------------------------------------------------------------------
begin
--|
--| Open channel to terminal
--|
    assign (status, "tt:", term_chan);
    if not success(status) then
	sys_exit (status);
    end if;

    put_line ("Font display");
--|
--| Get parameters
--|
    get_value (status, "font_file", font_file);
    chars := load_font (value (font_file));
    
    display := create_display (0.0, 0.0, 11.0, 22.0, 11.0, 22.0);
    window  := create_window (display, "sys$workstation", "Font display");
--|
--| Find first character
--|
    char := 0;
    while (chars(char) = null) and (char < 256) loop
	char := char + 1;
    end loop;
--|
--| Main program loop
--|
    loop
	erase (display);

	x_mag := float(chars(char).width)/float(chars(char).height);
	if (x_mag > 1.0) then x_mag := 1.0; end if;

	y_mag := float(chars(char).height)/float(chars(char).width);
	if (y_mag > 1.0) then y_mag := 1.0; end if;

	image (display, 0, 1.0, 12.0, 9.0*x_mag+1.0, 9.0*y_mag+12.0, 
	    chars(char).width, chars(char).height, 1, 
	    chars(char).bits'address);
		
	image_dc(window, 0, 10, 10, chars(char).width+10, 
	    chars(char).height+10, chars(char).width, 
	    chars(char).height, 1, chars(char).bits'address);

	put_line ("Character" & integer'image(char));
	get_command(term);
	case term is
	    
	    when done => exit;
		
	    when down =>
		for i in reverse 0..char-1 loop
		    if (chars(i) /= null) then
			char := i;
			exit;
		    end if;
		end loop;
		    
	    when up =>
		for i in char+1..255 loop
		    if (chars(i) /= null) then
			char := i;
			exit;
		    end if;
		end loop;
		    
	    when others =>
		put_line ("Unknown command");
	    
	end case;
    end loop;
end;
$ eod
$ checksum [.src]font.ada
$ if checksum$checksum .nes. "1782057255" then write sys$output -
    "    ******Checksum error for file [.src]font.ada******"
$ write sys$output "Creating [.src]font_def_.ada"
$ create [.src]font_def_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font_def							|--
--| Date:   28-AUG-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Define internal font structures.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    28-AUG-1986	New file.					|--
--| rcb	     2-JUN-1987	Change storage for V2 previewer.		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with unchecked_deallocation;

package font_def is

---------------------------------------------------------------------------
--|									|--
--| Font type definitions.						|--
--|									|--
---------------------------------------------------------------------------
type pixel_array is array (integer range <>) of boolean;
pragma pack (pixel_array);

type char_array (size : integer) is record
    height   : integer;
    width    : integer;
    x_offset : integer;
    y_offset : integer;
    x_delta  : float;
    bits     : pixel_array (1..size);
end record;

type char_ptr is access char_array;
type char_set is array (0..255) of char_ptr;

procedure free is new unchecked_deallocation (char_array, char_ptr);

type font_ptr is access char_set;
procedure free is new unchecked_deallocation (char_set, font_ptr);

end;
$ eod
$ checksum [.src]font_def_.ada
$ if checksum$checksum .nes. "1392846240" then write sys$output -
    "    ******Checksum error for file [.src]font_def_.ada******"
$ write sys$output "Creating [.src]font_io_.ada"
$ create [.src]font_io_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font_io							|--
--| Date:   28-AUG-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Handle all I/O to font files.				|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    28-AUG-1986	New file.					|--
--| rcb	     2-JUN-1987	Modified for version 2 previewer.		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with font_def;
use  font_def;

package font_io is

---------------------------------------------------------------------------
--|									|--
--| Routine defintions.							|--
--|									|--
---------------------------------------------------------------------------
function load_font (
    name : in string)
    return char_set;

end;
$ eod
$ checksum [.src]font_io_.ada
$ if checksum$checksum .nes. "2816" then write sys$output -
    "    ******Checksum error for file [.src]font_io_.ada******"
$ write sys$output "Creating [.src]font_io_pk.ada"
$ create [.src]font_io_pk.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font_io_pk							|--
--| Date:   28-AUG-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Handle all I/O to PK format font files.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    28-AUG-1986	New file.					|--
--| rcb	     7-MAY-1987	Modified GF font reader to be PK font reader.	|--
--| rcb	     2-JUN-1987	Modified for version 2 of previewer		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with system, condition_handling, sys, text_io, ots;
use  system, condition_handling, sys, text_io, ots;

with sequential_io;

package body font_io is

---------------------------------------------------------------------------
--|									|--
--| Constants								|--
--|									|--
---------------------------------------------------------------------------
--|
--| PK commands
--|
preamble  : constant := 247;
postamble : constant := 245;
pk_format : constant := 89;
---------------------------------------------------------------------------
--|									|--
--| Static variables.							|--
--|									|--
---------------------------------------------------------------------------
type font_node is array(1..512) of unsigned_byte;
package block_io is new sequential_io (font_node); use block_io;

font_file : block_io.file_type;
--font_rec  : block_io.count;
font_byte : integer;
font_buff : font_node;

low_nibble  : boolean;
high_nibble : integer;

dyn_f	     : integer;		-- Dynamic packing factor.
black_first  : boolean;		-- Start character with black pixels
repeat_count : integer := 0;	-- Number of repeats for current row.

---------------------------------------------------------------------------
--|									|--
--| Get_byte								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Return a byte from the file.			|--
--|									|--
---------------------------------------------------------------------------
function get_byte
    return integer is

begin
    font_byte := font_byte + 1;
    if (font_byte > 512) then
	font_byte := 1;
--	font_rec := font_rec + 1;
	read (font_file, font_buff);
    end if;
    
    return integer (font_buff(font_byte));
end;

---------------------------------------------------------------------------
--|									|--
--| Get_2byte								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Return a 2 byte value from the file.		|--
--|									|--
---------------------------------------------------------------------------
function get_2byte
    return integer is

temp : integer;

begin
    temp := get_byte;
    temp := temp*256 + get_byte;
    return temp;
end;

---------------------------------------------------------------------------
--|									|--
--| Get_3byte								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Return a 3 byte value from the file.		|--
--|									|--
---------------------------------------------------------------------------
function get_3byte
    return integer is

temp : integer;

begin
    temp := get_byte;
    temp := temp*256 + get_byte;
    temp := temp*256 + get_byte;
    return temp;
end;

---------------------------------------------------------------------------
--|									|--
--| Get_4byte								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Return a 4 byte value from the file.		|--
--|									|--
---------------------------------------------------------------------------
function get_4byte
    return integer is

temp : bit_array_32;

begin
    temp(24..31) := to_bit_array_8 (unsigned_byte (get_byte));
    temp(16..23) := to_bit_array_8 (unsigned_byte (get_byte));
    temp(8..15) := to_bit_array_8 (unsigned_byte (get_byte));
    temp(0..7) := to_bit_array_8 (unsigned_byte (get_byte));
    return integer (to_unsigned_longword (temp));
end;

---------------------------------------------------------------------------
--|									|--
--| Get_nibble								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Return the next nibble from the file.		|--
--|									|--
---------------------------------------------------------------------------
function get_nibble
    return integer is

temp : integer;

begin
    if not low_nibble then
	low_nibble := true;
	return high_nibble;
    else
	low_nibble := false;
	temp := get_byte;
	high_nibble := temp mod 16;
	return (temp / 16);
    end if;
end;

---------------------------------------------------------------------------
--|									|--
--| Get_run								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Get the next run count value from the file.		|--
--|									|--
---------------------------------------------------------------------------
function get_run 
    return integer is

temp  : integer;
count : integer := 0;

begin
    temp := get_nibble;
    if (temp = 0) then
	loop
	    temp := get_nibble;
	    count := count + 1;
	    exit when (temp /= 0);
	end loop;
	for i in 1..count loop
	    temp := temp*16+get_nibble;
	end loop;
	return (temp - 15 + (13 - dyn_f)*16 + dyn_f);
    else
	if (temp <= dyn_f) then
	    return temp;
	else
	    if (temp < 14) then
		return ((temp - dyn_f - 1)*16 + get_nibble + dyn_f + 1);
	    else
		if (repeat_count /= 0) then
		    put_line ("Second repeat count for a row");
		    sys_exit;
		end if;
		if (temp = 14) then
		    repeat_count := get_run;
		else
		    repeat_count := 1;
		end if;
		return get_run;
	    end if;
	end if;
    end if;
end;

---------------------------------------------------------------------------
--|									|--
--| Get_bits								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Character array entry to get bits for.		|--
--|									|--
--| Description:    Get the bit image of a character.			|--
--|									|--
---------------------------------------------------------------------------
procedure get_bits (
    char : in out char_array) is

line   : pixel_array (1..char.width);
pixel  : boolean := not black_first;
row    : integer := 1;
count  : integer := 0;

bit_row   : bit_array_8;
bit_count : integer := -1;

begin
--|
--| Check for a straight bitmap
--|
    if (dyn_f = 14) then
	for row in 1..char.height loop
	    for column in 1..char.width loop
		if (bit_count = -1) then
		    bit_row := to_bit_array_8 (unsigned_byte (get_byte));
		    bit_count := 7;
		end if;
		
		char.bits((row-1)*char.width+column) := bit_row(bit_count);
		bit_count := bit_count - 1;
	    end loop;
	end loop;
--|
--| Get run-encoded character
--|
    else
	while (row <= char.height) loop
	    repeat_count := 0;
	    for column in 1..char.width loop
		if (count = 0) then
		    count := get_run;
		    pixel := not pixel;
		end if;
		
		line(column) := pixel;
		count := count - 1;
	    end loop;
	    for i in 0..repeat_count loop
		char.bits((row-1)*char.width+1..row*char.width) := 
		    line(1..char.width);
		row := row + 1;
	    end loop;
	end loop;
    end if;
end;

---------------------------------------------------------------------------
--|									|--
--| Load_font								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Name of font file.				|--
--|									|--
--| Description:    Read in font file and convert it to internal	|--
--|		    raster representation.				|--
--|									|--
---------------------------------------------------------------------------
function load_font (
    name : in string)
    return char_set is

new_chars : char_set := (others => null);   -- Output character array

design_size : integer;	    -- Design size of font in points * 2e16
hppp        : integer;	    -- Horizontal pixels per point * 2e16
vppp	    : integer;	    -- Vertical pixels per point * 2e16
pix_ratio   : float;	    -- Design size in pixels

size     : integer;	    -- Size of a string/packet
trash    : integer;	    -- Any garbage value
x_size   : integer;	    -- Width of character
y_size   : integer;	    -- Height of character
x_offset : integer;	    -- Horizontal offset from top-left to reference
y_offset : integer;	    -- Vertical offset from top-left to reference
char     : integer;	    -- Character number.
tfm      : integer;	    -- TFM file width

begin
--|
--| Open font file
--|
    begin
	put_line ("Opening font file " & name & ".");
	open (font_file, in_file, "tex_vs_fonts:" & name);
--	font_rec := 0;
	font_byte := 512;
    exception
	when others =>
	    put_line ("Font file " & name & " not found.");
	    sys_exit;
    end;
--|
--| Get and trash preamble
--|
    if      (get_byte /= preamble)
    or else (get_byte /= pk_format) then
	put_line ("File " & name & " is not PK file format.");
	sys_exit;
    end if;
    
    size := get_byte;
    for i in 1..size loop
	trash := get_byte;
    end loop;
    
    design_size := get_4byte;
    trash       := get_4byte;
    hppp        := get_4byte;
    vppp        := get_4byte;

    pix_ratio := (float(design_size) / 1048576.0) * 
	(float(hppp) / 1048576.0);
---------------------------------------------------------------------------
--|									|--
--| Main character get loop.						|--
--|									|--
---------------------------------------------------------------------------
    loop
	trash := get_byte;
	if (trash >= 240) then
	    loop
		case trash is
		    when 240 => size := get_byte;
		    when 241 => size := get_2byte;
		    when 242 => size := get_3byte;
		    when 243 => size := get_4byte;
		    when 244 => size := 4;
		    when postamble => size := -1;
		    when others => size := 0;
		end case;
		for i in 1..size+1 loop
		    trash := get_byte;
		end loop;
		exit when (trash < 240) or (trash = postamble);
	    end loop;
	end if;

	exit when (trash = postamble);
--|
--| Get character header
--|
	dyn_f := trash / 16;		-- Get dynamic packing factor
	trash := trash mod 16;
	
	if (trash / 8 = 0) then		-- Get black first value
	    black_first := false;
	else
	    black_first := true;
	end if;
	trash := trash mod 8;
	
	if (trash < 4) then		-- One byte parameters
	    size     := get_byte + ((trash mod 4)*256) - 8;
	    char     := get_byte;
	    tfm      := get_3byte;
	    trash    := get_byte;
	    x_size   := get_byte;
	    y_size   := get_byte;
	    x_offset := get_byte;
	    y_offset := get_byte;
	    
	    if (x_offset > 127) then x_offset := x_offset - 256; end if;
	    if (y_offset > 127) then y_offset := y_offset - 256; end if;

	elsif (trash = 7) then		-- Four byte parameters
	    size     := get_4byte - 28;
	    char     := get_4byte;
	    tfm      := get_4byte;
	    trash    := get_4byte;
	    trash    := get_4byte;
	    x_size   := get_4byte;
	    y_size   := get_4byte;
	    x_offset := get_4byte;
	    y_offset := get_4byte;
	
	else				-- Two byte parameters
	    size     := get_2byte + ((trash mod 4)*65536) - 13;
	    char     := get_byte;
	    tfm      := get_3byte;
	    trash    := get_2byte;
	    x_size   := get_2byte;
	    y_size   := get_2byte;
	    x_offset := get_2byte;
	    y_offset := get_2byte;
	    
	    if (x_offset > 32767) then x_offset := x_offset - 65536; end if;
	    if (y_offset > 32767) then y_offset := y_offset - 65536; end if;
	end if;
--|
--| Create character
--|
	new_chars(char) := new char_array (y_size*x_size);
	new_chars(char).height := y_size;
	new_chars(char).width := x_size;
	new_chars(char).x_offset := -x_offset;
	new_chars(char).y_offset := y_offset - new_chars(char).height + 1;
	new_chars(char).x_delta := (float(tfm) / 65536.0) * pix_ratio;
	move5 (0, new_chars(char).bits'address, 0, (new_chars(char).size+7)/8,
	    new_chars(char).bits'address);
	
	low_nibble := true;
	get_bits (new_chars(char).all);
    end loop;
--|
--| Finish up
--|
    close (font_file);
    return new_chars;
end;

end;
$ eod
$ checksum [.src]font_io_pk.ada
$ if checksum$checksum .nes. "155960583" then write sys$output -
    "    ******Checksum error for file [.src]font_io_pk.ada******"
$ write sys$output "Creating [.src]font_tasks.ada"
$ create [.src]font_tasks.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font_tasks							|--
--| Date:    2-JUN-1987							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Driving tasks for font manipulation.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	     2-JUN-1987	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with font_io, str, text_io, sys;
use  font_io, str, text_io, sys;

package body font_tasks is

---------------------------------------------------------------------------
--|									|--
--| Static types and variables.						|--
--|									|--
---------------------------------------------------------------------------
--|
--| Font list types
--|
type font_node;
type font_node_ptr is access font_node;
type font_node is record
    font_number : integer := 0;
    font_name   : d_string;
    font        : font_ptr := null;
    next        : font_node_ptr := null;
end record;

font_head : font_node_ptr := null;
font_tail : font_node_ptr := null;

---------------------------------------------------------------------------
--|									|--
--| Font_load								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Load a set of fonts in the background.		|--
--|									|--
---------------------------------------------------------------------------
task body font_load is

temp  : font_node_ptr;
temp2 : font_ptr;

begin
    loop
	select
--|
--| Add new font to list
--|
	    accept add_font (font_name : in string; font_number : in integer) do
		temp := new font_node;
		temp.font_number := font_number;
		copy (temp.font_name, font_name);
		if (font_head = null) then
		    font_head := temp;
		else
		    font_tail.next := temp;
		end if;
		font_tail := temp;
	    end;
	or
--|
--| Go get fonts
--|
	    accept get_fonts;
	    exit;
	or
	    terminate;
	end select;
    end loop;
---------------------------------------------------------------------------
--|									|--
--| Main loop to get all fonts.						|--
--|									|--
---------------------------------------------------------------------------
    temp := font_head;
    while (temp /= null) loop
	temp2 := new char_set;
	temp2.all := load_font (value (temp.font_name));
	temp.font := temp2;
	font_search.check_again;
	temp := temp.next;
    end loop;
    font_search.load_done;
end;

---------------------------------------------------------------------------
--|									|--
--| Font_search								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Description:    Search for a font and see if it has been		|--
--|		    loaded yet.						|--
--|									|--
---------------------------------------------------------------------------
task body font_search is

temp : font_node_ptr;
done : boolean := false;

begin
    loop
--|
--| Accept status calls outside of a search.
--|
	select
	    accept check_again;
	or
	    accept load_done;
	    done := true;
	or
--|
--| Search for a font by number
--|
	    accept find_font (font_number : in integer; font : out font_ptr) do
		temp := font_head;
		while (temp /= null) loop
		    exit when (temp.font_number = font_number);
		    temp := temp.next;
		end loop;
		
		if (temp = null) then
		    put_line ("Font" & integer'image(font_number) & 
			" not found.");
		    sys_exit;
		end if;
--|
--| Either return font pointer or wait for it to be loaded.
--|
		if (temp.font = null) then
		    loop
			if (done) then
			    put_line ("Font not being loaded");
			    sys_exit;
			end if;
			
			select
			    accept check_again;
			or
			    accept load_done;
			    done := true;
			or 
			    terminate;
			end select;
			
			exit when (temp.font /= null);
		    end loop;
		end if;
		font := temp.font;
	    end;
	or
	    terminate;
	end select;
    end loop;
end;

end;
$ eod
$ checksum [.src]font_tasks.ada
$ if checksum$checksum .nes. "1429518831" then write sys$output -
    "    ******Checksum error for file [.src]font_tasks.ada******"
$ write sys$output "Creating [.src]font_tasks_.ada"
$ create [.src]font_tasks_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Font_tasks							|--
--| Date:    2-JUN-1987							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Driving tasks for font manipulation.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	     2-JUN-1987	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with font_def;
use  font_def;

package font_tasks is

---------------------------------------------------------------------------
--|									|--
--| Task definitions.							|--
--|									|--
---------------------------------------------------------------------------
task font_load is
    pragma priority(5);
    entry add_font (font_name : in string; font_number : in integer);
    entry get_fonts;
end;

task font_search is
    pragma priority(6);
    entry find_font (font_number : in integer; font : out font_ptr);
    entry check_again;
    entry load_done;
end;

end;
$ eod
$ checksum [.src]font_tasks_.ada
$ if checksum$checksum .nes. "823410064" then write sys$output -
    "    ******Checksum error for file [.src]font_tasks_.ada******"
$ write sys$output "Creating [.src]preview.ada"
$ create [.src]preview.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Preview							|--
--| Date:    3-SEP-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Preview a dvi file on a vaxstation.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	     3-SEP-1986	New file.					|--
--| rcb	    20-NOV-1986	Changed shift size to half of visable area.	|--
--| rcb	     2-JUN-1987	Modified to version 2 previewer.		|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with cli, str, text_io, integer_text_io, condition_handling, float_text_io;
use  cli, str, text_io, integer_text_io, condition_handling, float_text_io;

with dvi_tasks, dvi_def, uis, starlet, tasking_services, system, sys;
use  dvi_tasks, dvi_def, uis, starlet, tasking_services, system, sys;

procedure preview is
pragma priority (7);

---------------------------------------------------------------------------
--|									|--
--| Static variables							|--
--|									|--
---------------------------------------------------------------------------
type terminator is (up, down, left, right, nxt_page, prv_page, goto_page, 
    grid, done);

term      : terminator;
term_chan : channel_type;
status    : cond_value_type;
in_line   : d_string;
--|
--| Cli variables
--|
dvi_file : d_string;
temp     : d_string;
magstep  : integer;
magnify  : float := 1.0;
last     : natural;
--|
--| Display variables
--|
display_page  : page_ptr := null;
curr_page_num : integer := 0;
next_page_num : integer := 0;
page_count    : integer := 0;
redisplay     : boolean := true;
display       : uis.display_type;
window        : uis.window_type;

grid_active : boolean := false;
grid_size   : float;
grid_gap    : integer;
grid_temp   : integer;

max_height     : constant float := 27.0;
height         : float := 28.05;
visible_height : float := 28.05;
llx	       : integer;
urx	       : integer;
delta_x	       : integer;
min_x	       : integer;

max_width      : constant float := 33.0;
width          : float := 21.7;
visible_width  : float := 21.7;
curr_offset    : integer := 1;
max_offset     : integer;
pixel_height   : integer;

cent_to_pix : constant float := 30.588;

---------------------------------------------------------------------------
--|									|--
--| Get_command								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Command code.					|--
--|									|--
--| Description:    Get bytes from the terminal and see if they		|--
--|		    form a known command.				|--
--|									|--
---------------------------------------------------------------------------
procedure get_command (
    term : in out terminator) is

trash : integer;

function get_char
    return integer is

code   : integer := 0;
status : cond_value_type;

begin
    task_qiow (
	status => status,
	chan   => term_chan,
	func   => io_readvblk or io_m_noecho,
	p1     => to_unsigned_longword (code'address),
	p2     => 1);
    return code;
end;	

begin
    loop
	case get_char is
	    when 26 => term := done; exit;
	    when 27 =>
		case get_char is
		    when 91 =>
			case get_char is
			    when 65 => term := up;        exit;
			    when 66 => term := down;      exit;
			    when 67 => term := right;     exit;
			    when 68 => term := left;      exit;
			    when 49 => term := grid;      exit;
			    when 52 => term := goto_page; exit;
			    when 53 => term := prv_page;  exit;
			    when 54 => term := nxt_page;  exit;
			    when others => put_line ("Invalid command.");
			end case;
		    when others => put_line ("Invalid command.");
		end case;
	    when others => put_line ("Invalid command.");
	end case;
    end loop;
    
    if (term in nxt_page..grid) then
	trash := get_char;
    end if;
end;

---------------------------------------------------------------------------
--|									|--
--| Main program							|--
--|									|--
---------------------------------------------------------------------------
begin
    put_line ("Dvi Previewer");
--|
--| Get parameters
--|
    get_value (status, "dvi_file", dvi_file);
    get_value (status, "magstep", temp);
    get (value (temp), magstep, last);
    
    for i in 1..magstep loop
	magnify := magnify * 1.2;
    end loop;
--|
--| Activate dvi display code
--|
    dvi_read.init (value (dvi_file), magnify, page_count);
    prev_page := new page_array (page_width*page_height);
    reset_page (prev_page);
    curr_page := new page_array (page_width*page_height);
    reset_page (curr_page);
    next_page := new page_array (page_width*page_height);
    reset_page (next_page);
--|
--| Open channel to terminal
--|
    assign (status, "tt:", term_chan);
    if not success(status) then
	sys_exit (status);
    end if;
--|
--| Start UIS stuff
--|
    height := height * magnify;
    if (height > max_height) then 
	visible_height := max_height;
    else
	visible_height := height;
    end if;
    
    width := width * magnify;
    if (width > max_width) then 
	visible_width := max_width;
    else
	visible_width := width;
    end if;

    display := create_display (0.0, 0.0, visible_width, visible_height,
	visible_width, visible_height);
    disable_display_list (display);
    window := create_window (display, "sys$workstation", "Dvi Previewer");
    
    delta_x := integer(visible_width/2.0*cent_to_pix);
    min_x := integer((visible_width-width)*cent_to_pix);
    llx := 0;
    urx := integer(visible_width * cent_to_pix);

    pixel_height := integer(visible_height*cent_to_pix);
    max_offset := (page_height-pixel_height)*page_width + 1;
    
    set_writing_mode (display, 0, 1, 3);
    set_line_style (display, 1, 1, 16#11111111#);
--|
--| Get first page
--|
    dvi_read.get_page (1, display_page);
    curr_page_num := 1;
    put_line ("Page" & integer'image (curr_page_num) & " of" &
	integer'image (page_count));

---------------------------------------------------------------------------
--|									|--
--| Main loop								|--
--|									|--
---------------------------------------------------------------------------
    loop
	if redisplay then
	    image_dc (window, 0, llx, 0, urx, pixel_height,
		page_width, pixel_height, 1, 
		display_page.bits(curr_offset)'address);
	    redisplay := false;
	    grid_active := false;
	end if;
	
	get_command (term);
	case term is
--|
--| Exit program
--|
	    when done => exit;
--|
--| Goto next page.
--|
	    when nxt_page =>
		if (curr_page_num < page_count) then
		    erase_dc (window);
		    dvi_read.get_next (display_page);
		    redisplay := true;
		    curr_page_num := curr_page_num + 1;
		    put_line ("Page" & integer'image (curr_page_num) &
			" of" & integer'image (page_count));
		else
		    put_line ("No next page.");
		end if;
--|
--| Goto previous page
--|
	    when prv_page =>
		if (curr_page_num > 1) then
		    erase_dc (window);
		    dvi_read.get_prev (display_page);
		    redisplay := true;
		    curr_page_num := curr_page_num - 1;
		    put_line ("Page" & integer'image (curr_page_num) &
			" of" & integer'image (page_count));
		else
		    put_line ("No previous page.");
		end if;
--|
--| Goto arbitrary page
--|
	    when goto_page =>
		put ("Enter page number: ");
		begin
		    get (next_page_num);
		exception
		    when others => next_page_num := 0;
		end;
		
		if (next_page_num in 1..page_count) then
		    erase_dc (window);
		    curr_page_num := next_page_num;
		    dvi_read.get_page (curr_page_num, display_page);
		    redisplay := true;
		    put_line ("Page" & integer'image (curr_page_num) &
			" of" & integer'image (page_count));
		else
		    put_line ("Invalid page number" & integer'image(next_page_num));
		end if;
--|
--| Go up on page
--|
	    when up =>
		curr_offset := curr_offset - 
		    integer(visible_height/2.0*cent_to_pix)*page_width;
		if (curr_offset < 1) then
		    curr_offset := 1;
		end if;
		erase_dc (window);
		redisplay := true;
--|
--| Go down on page
--|
	    when down =>
		curr_offset := curr_offset +
		    integer(visible_height/2.0*cent_to_pix)*page_width;
		if (curr_offset > max_offset) then
		    curr_offset := max_offset;
		end if;
		erase_dc (window);
		redisplay := true;
--|
--| Go right on page
--|
	    when right =>
		llx := llx - delta_x;
		if (llx < min_x) then
		    llx := min_x;
		end if;
		erase_dc (window);
		redisplay := true;
--|
--| Go left on page
--|
	    when left =>
		llx := llx + delta_x;
		if (llx > 0) then
		    llx := 0;
		end if;
		erase_dc (window);
		redisplay := true;
--|
--| Overlay display with grid
--|
	    when grid =>
		if not grid_active then
		    put ("Grid size (in inches)? ");
		    begin
			get_line (in_line);
			get (value(in_line), grid_size, last);
		    exception
			when others => grid_size := 1.0;
		    end;
		end if;
		
		grid_active := not grid_active;
		grid_gap := integer(grid_size*resolution*magnify);
		if (grid_gap < 1) then
		    grid_gap := 1;
		end if;

		grid_temp := 0;
		while (grid_temp < display_page.width) loop
		    plot_dc (window, 1, grid_temp+llx, 0, grid_temp+llx, 
			    integer(visible_height*cent_to_pix));
		    grid_temp := grid_temp + grid_gap;
		end loop;

		grid_temp := pixel_height-page_height+(curr_offset/page_width);
		while (grid_temp < display_page.height) loop
		    plot_dc (window, 1, 0, grid_temp,
			integer(visible_width*cent_to_pix), grid_temp);
		    grid_temp := grid_temp + grid_gap;
		end loop;

	end case;
    end loop;
end;
$ eod
$ checksum [.src]preview.ada
$ if checksum$checksum .nes. "320031064" then write sys$output -
    "    ******Checksum error for file [.src]preview.ada******"
$ write sys$output "Creating [.src]uis_.ada"
$ create [.src]uis_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Uis								|--
--| Date:   28-AUG-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Define UIS routines.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    28-AUG-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. Research Triangle Institute supplies this software "as is",	|--
--|	without any warranty. The author and the Institute do not	|--
--|	accept any responsibility for any damage caused by use or	|--
--|	mis-use of this program.					|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with system;
use  system;

package uis is

---------------------------------------------------------------------------
--|									|--
--| Type definitions							|--
--|									|--
---------------------------------------------------------------------------
subtype display_type is integer;
subtype window_type is integer;

---------------------------------------------------------------------------
--|									|--
--| Routine defintions							|--
--|									|--
---------------------------------------------------------------------------
function create_display (
    llx : in float;
    lly : in float;
    urx : in float;
    ury : in float;
    width  : in float;
    height : in float)
    return display_type;

pragma interface (rtl, create_display);
pragma import_function (create_display, "uis$create_display");

function create_window (
    display : in display_type;
    name    : in string := "sys$workstation";
    label   : in string := "";
    llx     : in float := float'null_parameter;
    lly     : in float := float'null_parameter;
    urx     : in float := float'null_parameter;
    ury     : in float := float'null_parameter;
    width   : in float := float'null_parameter;
    height  : in float := float'null_parameter)
    return window_type;

pragma interface (rtl, create_window);
pragma import_function (create_window, "uis$create_window");

procedure disable_display_list (
    display : in display_type;
    flags   : in integer := integer'null_parameter);

pragma interface (rtl, disable_display_list);
pragma import_procedure (disable_display_list, "uis$disable_display_list");

procedure erase_dc (
    window : in window_type);

pragma interface (rtl, erase_dc);
pragma import_procedure (erase_dc, "uisdc$erase");

procedure erase (
    display : in display_type);

pragma interface (rtl, erase);
pragma import_procedure (erase, "uis$erase");


procedure image (
    display    : in display_type;
    attribute  : in integer := 0;
    llx        : in float;
    lly        : in float;
    urx        : in float;
    ury        : in float;
    width      : in integer;
    height     : in integer;
    pixel_bits : in integer := 1;
    buffer     : in address);

pragma interface (rtl, image);
pragma import_procedure (image, "uis$image",
    (display_type, integer, float, float, float, float, integer, 
	integer, integer, address),
    (reference, reference, reference, reference, reference, reference,
	reference, reference, reference, value));

procedure image_dc (
    window     : in window_type;
    attribute  : in integer := 0;
    llx        : in integer;
    lly        : in integer;
    urx        : in integer;
    ury        : in integer;
    width      : in integer;
    height     : in integer;
    pixel_bits : in integer := 1;
    buffer     : in address);

pragma interface (rtl, image_dc);
pragma import_procedure (image_dc, "uisdc$image",
    (window_type, integer, integer, integer, integer, integer, integer, 
	integer, integer, address),
    (reference, reference, reference, reference, reference, reference,
	reference, reference, reference, value));

procedure plot (
    display : in display_type;
    attr    : in integer;
    x1      : in float;
    y1      : in float;
    x2      : in float;
    y2      : in float);

pragma interface (rtl, plot);
pragma import_procedure (plot, "uis$plot");

procedure plot_dc (
    window  : in window_type;
    attr    : in integer;
    x1      : in integer;
    y1      : in integer;
    x2      : in integer;
    y2      : in integer);

pragma interface (rtl, plot_dc);
pragma import_procedure (plot_dc, "uisdc$plot");

procedure set_line_style (
    display  : in display_type;
    in_attr  : in integer;
    out_attr : in integer;
    pattern  : in integer);

pragma interface (rtl, set_line_style);
pragma import_procedure (set_line_style, "uis$set_line_style");

procedure set_writing_mode (
    display  : in display_type;
    in_attr  : in integer;
    out_attr : in integer;
    pattern  : in integer);

pragma interface (rtl, set_writing_mode);
pragma import_procedure (set_writing_mode, "uis$set_writing_mode");

end;
$ eod
$ checksum [.src]uis_.ada
$ if checksum$checksum .nes. "1212495686" then write sys$output -
    "    ******Checksum error for file [.src]uis_.ada******"
$ exit