Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 9 < prev next >

Wrap

Text File | 1993-09-02 | 49.4 KB | 1,699 lines

Article 100 of comp.sources.misc: Relay-Version: version B 2.10.3 alpha 5/22/85; site osu-eddie.UUCP Path: osu-eddie!cbosgd!ihnp4!ptsfa!ames!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: 7 Jul 87 01:48:48 GMT Date-Received: 8 Jul 87 03:35:38 GMT Sender: allbery@ncoast.UUCP Lines: 1682 Approved: allbery@ncoast.UUCP X-Archive: comp.sources.misc/8707/9 $ 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