IMD 1.17: 14/03/2012 8:55:52 DGL: B3466A 3.5" DS  €DGL    p  ASM_SCLIPTéK 2“ H €1ęASM_STEXTTéK>"“ H€!aDGL_AUTLT_éK`“ H%€źDGL_C_INT_éKo“ H4€ďDGL_C_OUTTéKŒ]“ HV€\xDGL_HILIT_éKé“ I€3DGL_HPGLT_éKú,“ I€+;DGL_HPGLITéK&“ I €aDGL_IBODYTéK7 “ I%€ eDGL_INQT__éKAC“ IB€BDGL_POLYT_éK„“ P€3DGL_RAST__éKc“ P@€bsDGL_TOOLSTéKw“ PF€ŔDGL_VARST_éK‡6“ Q€51GENT______éK˝I“ Q€H5GLE_AUTLT_éK “ Q&€ ŞGLE_FILET_éK“ Q4€ @GLE_GENT__éK “ QF€GLE_GENIT_éK@“ QU€ŽGLE_HILIT_éKO“ R€WGLE_HPGLT_éKlZ“ R2€YĚGLE_HPIBT_éKĆ=“ RQ€<…GLE_KNOBT_éK “ S€ĐGLE_RGLT__éK#““ SA€’öGLE_SCLIPTéKś“ SH€ČGLE_STEXTTéKž“ SX€@GLE_TYPESTéKŃ7“ T€6[GLE_UTLST_éK“ T&€aG_HILRELT_éK"“ T9€!˛LIBT______éK>“ U€œPOPTIONST__éKŰ“ U%€¸RGLT______éKޤ“ X€ŁSTROKEST__éK‚&“ X€%WTYPEST____éK¨“ X&€ MAKE_DGLT_éK°“ X7€€ASM_TYPESTéKŔ “ XG€ „DGL_KNOBT_éKĚ“ Y€D_HILRELT_éKĺ“ Y€ţGLE_HPGLITéKö.“ Y0€-rGLE_SMARKTéK $!“ YE€ :READMET___ EpU€READMET___ H“ €JREADMET___éK M“ @€K ˙˙@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@* Graphics Low End * * Module = Software clipping * Programer = BJS * Date = 10-5-82 * * Purpose : To provide software clipping routines. * * Rev history * * Created - 10- 5-82 * Modified - 11-23-82 Removed test for static links on proc calls * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * mname GLE_ASCLIP src module GLE_ASCLIP; src import GLE_TYPES; src export src procedure gle_soft_clip_move ( gcb : graphics_control_block_ptr ); src  procedure gle_soft_clip_draw ( gcb : graphics_control_block_ptr ); src end; nosyms * * * Define entry points * rorg 0 def GLE_ASCLIP_GLE_SOFT_CLIP_MOVE def GLE_ASCLIP_GLE_SOFT_CLIP_DRAW def GLE_ASCLIP_CLIPPING def GLE_ASCLIP_GLE_ASCLIP * * Set up globals * GCB equ a4 X0 equ d4 Y0 equ d5 X1 equ d6 Y1 equ d7 clip_xmin equ a0 clip_xmax equ a1 clip_ymin equ a2 clip_ymax equ a3 INCLUDE ASM_TYPES * ***************************************************************************** * GLE_ASCLIP_GLE_SOFT_CLIP_MOVE equ * link a6,#0 movea.l 8(a6),gcb { A4 } move.l end_x(gcb),-(sp) { save ending point, this will } move.l end_y(gcb),-(sp) { become the new cp } bsr clip { returns clipped points in } * { (d4,d5) and (d6,d7), d0 is} * { the clipped state opcode } cmp.w  #2,d0 {ck for total clip} beq.s move_complete move.l d6,end_x(gcb) { pass clipped point } move.l d7,end_y(gcb) move.l gcb,-(sp) { save copy of gcb on stack }  move.l gcb,-(sp) { call move routine } movea.l unclipped_move(gcb),a0 { no static links } jsr (a0) movea.l (sp)+,gcb { get gcb back off stack } move_complete equ * move.l (sp)+,current_pos_y(gcb) { set cp to saved end_x, end_y } move.l (sp)+,current_pos_x(gcb) { saved on stack. Note that } * { the CP is saved in an unclipped } * { form } unlk a6 move.l (sp)+,(sp) rts ****************************************************************************** GLE_ASCLIP_GLE_SOFT_CLIP_DRAW equ * link a6,#0 movea.l 8(a6),gcb { A4 } move.l end_x(gcb),-(sp) { save ending point, this will } move.l end_y(gcb),-(sp) { become the new cp } bsr clip { returns clipped points in } *  { (d4,d5) and (d6,d7), d0 is} * { the clipped state opcode } tst.w d0 { ck for no clipping needed } beq.s draw_it cmp.w  #2,d0 {ck for line outside clipping bounds} beq.s draw_complete cmp.l current_pos_x(gcb),d4 { ck to see if cp changed after } bne.s move_first { clipping } cmp.l current_pos_y(gcb),d5 beq.s draw_it move_first equ * move.l d6,-(sp) { save end point on stack } move.l d7,-(sp) move.l d4,end_x(gcb) { pass clipped point } move.l d5,end_y(gcb) move.l gcb,-(sp) { save a copy of gcb pointer } move.l gcb,-(sp) { call move routine } movea.l unclipped_move(gcb),a0 { no static links } jsr (a0) movea.l (sp)+,gcb { get gcb pointer back } move.l (sp)+,d7 { pass clipped point } move.l (sp)+,d6 draw_it equ * move.l d6,end_x(gcb) move.l d7,end_y(gcb) move.l gcb,-(sp)  { save copy of gcb on stack } move.l gcb,-(sp) movea.l unclipped_draw(gcb),a0 { no static links } jsr (a0) movea.l (sp)+,gcb { get gcb back } draw_complete equ * move.l (sp)+,current_pos_y(gcb) { set cp to saved end_x, end_y } move.l (sp)+,current_pos_x(gcb) { saved on stack. Note that } * { the CP is saved in an unclipped } * { form   } unlk a6 move.l (sp)+,(sp) rts **************************************************************************** * * * ASM clipping entry point is GLE_ASCLIP_CLIPPING * * Regs = a0 - clip_xmin d4 - x0 *  a1 - clip_ymin d5 - y0 * a2 - clip_xmax d6 - x1 * a3 - clip_ymax d7 - y1 * * a4 - GLE_GCB * **************************************************************************** * * clip * * d4=x0 a0=clip_xmin *  d5=y0 a1=clip_ymin * d6=x1 a2=clip_xmax * d7=y1 a3=clip_ymax * * Returns clipped points (x0,y0) and (x1,y1) * Returns opcode in d0 : 0 - not clipped * 1 - clipped but some part visible *  2 - all clipped * clip equ * movem.l current_pos_x(gcb),d4-d7 { get x0,y0 x1,y1 } movem.l clip_limits_xmin(gcb),a0-a3 cmp.l clip_xmin,x0 fast check to find in bounds line blt.s clip_it cmp.l clip_xmax,x0 bgt.s clip_it cmp.l clip_ymin,y0 blt.s clip_it cmp.l clip_ymax,y0 bgt.s clip_it cmp.l clip_xmin,x1 blt.s clip_it cmp.l clip_xmax,x1 bgt.s clip_it cmp.l clip_ymin,y1 blt.s clip_it cmp.l clip_ymax,y1 bgt.s clip_it clipallin equ * moveq #0,d0 no clipping performed, set return opcode rts GLE_ASCLIP_CLIPPING equ * clip_it move.l a5,-(sp) {save global base, and free up a5} clr.w soft_clip_switch(gcb) cmp.l y1,y0 check for horizontal lines beq clip_horizontal blt.s clip1 force y0 < y1 exg x0,x1 exg y0,y1 bchg #0,soft_clip_switch(gcb) clip1 cmp.l clip_ymax,y0 ck for both y above bgt clip_out cmp.l clip_ymin,y1 ck for both y below blt clip_out cmp.l x1,x0 check for vertical lines beq clip_vertical blt.s clip2 now force x0 < x1 exg x0,x1 exg y0,y1 bchg #0,soft_clip_switch(gcb) clip2 cmp.l clip_xmax,x0 ck for both x left bgt clip_out cmp.l clip_xmin,x1 ck for both x right blt clip_out * * At this point, a diagonal line exists with one or two ends * outside the current clipping limits. This line is reduced by replacing * its end points with window intersections. Intersections are found * by using the midpoint clipping procedure (Newman&Sproull) * solv_x1 move.l x0,soft_clip_savex0(gcb) save original points move.l y0,soft_clip_savey0(gcb) move.l x1,soft_clip_savex1(gcb) move.l y1,soft_clip_savey1(gcb) cmp.l clip_xmin,x0 is x0 inside? bge.s solv_xr solv_xl movea.l clip_xmin,a5 solve for y at (x = xmin) move.l x0,d0 pass parms to solve move.l y0,d1 (note: x0 = d4, y0 = d5) move.l y0,d3 (lefty) move.l x0,d2 (leftx) move.l y1,d5 (righty) move.l x1,d4 (rightx) bsr solve move.l d0,x0 move.l d1,y0 move.l x0,soft_clip_savex0(gcb) move.l y0,soft_clip_savey0(gcb) solv_xr cmp.l clip_xmax,x1 is x1 inside? ble.s intsct3  movea.l clip_xmax,a5 solve for y at (x = xmax) move.l x1,d0 pass parms to solve move.l y1,d1 (note: x0 = d4, y0 = d5) move.l x0,x1 free up d4, d5 (x1, an y1 are now free) move.l y0,y1 move.l  soft_clip_savey1(gcb),d5 move.l soft_clip_savex1(gcb),d4 move.l soft_clip_savey0(gcb),d3 move.l soft_clip_savex0(gcb),d2 bsr solve move.l x1,x0 restore x0,y0 move.l y1,y0 move.l d0,x1 move.l d1,y1 move.l x1,soft_clip_savex1(gcb) move.l y1,soft_clip_savey1(gcb) intsct3 cmp.l y1,y0 force y2 > y1 blt.s intsct4 exg x0,x1 exg y0,y1 move.l soft_clip_savex0(gcb),d0 swap saved copies as well move.l soft_clip_savex1(gcb),soft_clip_savex0(gcb) move.l d0,soft_clip_savex1(gcb) move.l soft_clip_savey0(gcb),d0 move.l soft_clip_savey1(gcb),soft_clip_savey0(gcb) move.l d0,soft_clip_savey1(gcb) bchg #0,soft_clip_switch(gcb) intsct4 cmp.l clip_ymax,y0 bgt clip_out cmp.l  clip_ymin,y1 blt clip_out solv_yu cmp.l clip_ymin,y0 bge.s solv_yd movea.l clip_ymin,a5 solve for x at (y = ymin) move.l soft_clip_savex0(gcb),d3 Pass parms to solve move.l soft_clip_savey0(gcb),d2 move.l soft_clip_savey0(gcb),d0 move.l soft_clip_savex0(gcb),d1 move.l soft_clip_savex1(gcb),d5 move.l soft_clip_savey1(gcb),d4 bsr solve move.l d0,y0 move.l d1,x0 move.l y0,soft_clip_savey0(gcb) move.l x0,soft_clip_savex0(gcb) solv_yd cmp.l clip_ymax,y1 ble clip_in movea.l clip_ymax,a5 solve for x at (y = ymin) move.l x0,x1 (save x0,y0 in x1,y1 which is free) move.l y0,y1 move.l soft_clip_savex1(gcb),d5 move.l soft_clip_savey1(gcb),d4 move.l soft_clip_savex0(gcb),d3 move.l soft_clip_savey0(gcb),d2 move.l soft_clip_savey1(gcb),d0 move.l soft_clip_savex1(gcb),d1 bsr solve move.l x1,x0 restore x0,y0 move.l y1,y0 move.l d0,y1 move.l d1,x1 clip_in equ * btst #0,soft_clip_switch(gcb) beq.s clipin exg x0,x1 restore org direction exg y0,y1 clipin equ * moveq #1,d0 clipping one or more points movea.l (sp)+,a5 {restore global base} rts clip_all_in equ * movea.l (sp)+,a5  {restore global base} btst #0,soft_clip_switch(gcb) beq clipallin exg x0,x1 restore org direction exg y0,y1 bra clipallin clip_out equ * moveq #2,d0 all clipped, set up return opcode movea.l (sp)+,a5 {restore global base} rts clip_horizontal equ * cmp.l clip_ymax,y1 ck for y out of clip limits bgt clip_out cmp.l clip_ymin,y1 blt clip_out cmp.l x1,x0 beq clip_dot blt.s clip_h1 exg x0,x1 bchg #0,soft_clip_switch(gcb) clip_h1 cmp.l clip_xmax,x0 x0 < x1 bgt clip_out cmp.l clip_xmin,x1 blt clip_out cmp.l clip_xmax,x1 ble.s clip_h2 move.l clip_xmax,x1 clip_h2 cmp.l clip_xmin,x0 bge.s clip_in move.l clip_xmin,x0 bra.s clip_in clip_vertical equ * cmp.l clip_xmax,x1 bgt clip_out cmp.l clip_xmin,x1 blt clip_out cmp.l clip_ymax,y1 assumes y0 < y1 ble.s clip_v1 move.l clip_ymax,y1 clip_v1 cmp.l clip_ymin,y0 bge clip_in move.l clip_ymin,y0 bra clip_in clip_dot equ * cmp.l clip_xmax,x0 bgt clip_out cmp.l clip_xmin,x0 blt clip_out bra clip_in * routine to find intersections. D0 will be driven to the value supplied * as val_x. D1 will contain the corresponding value. "left" and "right" * contain the original starting points. "X" and "Y" are only reletive * to the current use of this routine, not the physical bounds of the * display * solve equ * val_x equ a5 right_y equ d5 right_x equ d4 left_y equ d3 left_x equ d2 solve_s cmp.l val_x,d0 beq.s solve_e blt.s solve_l solve_r move.l d0,right_x move.l d1,right_y add.l left_x,d0 bvs.s force_exit check for overflow add.l left_y,d1 bvs.s force_exit  check for overflow bra.s round solve_l move.l d0,left_x move.l d1,left_y add.l right_x,d0 bvs.s force_exit check for overflow addq.l #1,d0 bvs.s force_exit check for overflow add.l right_y,d1 bvs.s force_exit  check for overflow addq.l #1,d1 bvs.s force_exit check for overflow round asr.l #1,d0 asr.l #1,d1 bra.s solve_s force_exit trapv let system process solve_e rts gle_asclip_gle_asclip rts * * Graphics Low End * * Module = Software text * Programer = BJS * Date = 9-30-82 * * Purpose : To provide software text generation routines. * * Rev history * * Created - 9-30-82 * Modified - 6-27-83 BJS Added export text for soft_text routine * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett- Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * mname GLE_ASTEXT src module GLE_ASTEXT; src import GLE_TYPES; src export src procedure gle_soft_text ( gcb : graphics_control_block_ptr ); src end; nosyms * * Export text is defined by STEXT Pascal module * * * Define entry points * rorg 0 def GLE_ASTEXT_GLE_SOFT_TEXT def GLE_ASTEXT_GLE_ASTEXT * * Set up globals * GCB equ a0 INCLUDE ASM_TYPES cosx_tab equ 0 cosy_tab equ 16 sinx_tab equ 48 siny_tab equ 64 * ***************************************************************************** * GLE_ASTEXT_GLE_SOFT_TEXT equ * trap #1 stack overflow ck dc.w 0 * * Check calc_text_xform to see if the transformation needs * to be re-calcultated. * movea.l 8(a6),gcb {A0} tst.w calc_text_xform(gcb) beq xform_ok move.l gcb,-(sp) {pass gcb} s0 movea.l calc_soft_text_xform(gcb),a0  { no static links } jsr (a0) xform_ok equ * * * Get GCB pointer * Move string address to local address reg * Move cnt to local address reg * Get addr of stroke table in local address reg * movea.l 8(a6),gcb {A0} movea.l info_ptr1(gcb),a1 {string ptr} move.l info1(gcb),d0 {string count} * * * save a copy of starting cp in temp (this is used for CR point) * move.l current_pos_x(gcb),d1 move.l current_pos_y(gcb),d7  move.l d1,soft_text_temp1(gcb) move.l d7,soft_text_temp2(gcb) movea.l #0,a4 * NEXT_CHAR equ * bad_char equ * {bad characters are ignored} * * Top of loop * Check character count; Quit if 0 * sub.w #1,d0  {=0?} blt DONE * * Get current character from string * moveq #0,d1 {clear high byte} move.b (a1)+,d1 {d1 <- char} adda.l #1,a4 * * Calc which font tables to use * movea.l soft_font_ptr(gcb),A2 {Pointer to stroke tables} movea.l a2,a3 {copy stroke table pointer} sub.w #32,d1 {all char < 32 are control} blt control cmp.w #95,d1 {ck for char > 127} bgt plot_hi cmp.w  #60,d1 {ck for sqr root (special kata) bne plot_std tst.w kata(gcb) {ck katakana flag} beq.s plot_std moveq #63,d1 {use kata char #63 for sqr root} bra plot_kata plot_hi equ * tst.w kata(gcb) {ck katakana flag} beq.s plot_rom sub.w #129,d1 {legal kata from 161 to 223} blt bad_char cmp.w #62,d1 bgt bad_char plot_kata equ * * adda.l $14(a2),a3 {A3 points to top of KATA Pointer table} adda.l $10(a2),a2 {A2 points to top of KATA stroke table} bra plot_common plot_rom equ * sub.w #136,d1 {legal roman are 168 to 222} blt bad_char cmp.w #54,d1 bgt bad_char * adda.l $C(a2),a3 {A3 points to top of KATA Pointer table} adda.l $8(a2),a2 {A2 points to top of KATA stroke table} bra plot_common plot_std equ * {STD is first entry in stroke table} * adda.l 4(a2),a3 {A3 points to top of Pointer table} adda.l (a2),a2 {A2 points to top of stroke table} * ******************************************************************************* * plot_common equ * * * Calc number of vectors in character by indexing into pointer sub-table * add.w d1,d1 {calc 16 bit offset with character} move.w 2(a3,d1),d5 {get index of first vector of next char} move.w 0(a3,d1),d6 {get index of first vector of this  char} sub.w d6,d5 {d5 is the number of vectors in char} * * Calc indexs to vector locations in stroke table * sub.w #1,d6 {pointer are base 1, we need base 0} adda.w d6,a2 {form ptr to first vector} * * move current position into local regs * move.l current_pos_x(gcb),d1 {X} move.l current_pos_y(gcb),d7 {Y} * VECTOR_LOOP equ * * * Top of vector loop * move.b (a2)+,d4 { get packed vector information } move.b d4,d2  { unpack x information } lsr.w #4,d2 and.w #$0007,d2 add.w d2,d2 { form word index into cos table } move.b d4,d3 { unpack y information } and.w #$000f,d3 add.w d3,d3 { form word index into cos table } movea.l gcb,a3 adda.l #cosx_table,a3 move.w cosx_tab(a3,d2.w),d6 add.w siny_tab(a3,d3.w),d6 { d6 is new X } ext.l d6 move.w cosy_tab(a3,d3.w),d3 add.w sinx_tab(a3,d2.w),d3 { d3 is new Y } ext.l d3 add.l d1,d6 {translate by CP} bvs range_error add.l d7,d3 bvs range_error movem.l d0/d1/d5/d7/a0-a2/a4,-(sp) {save local state} move.l gcb,-(sp) {pass gcb} move.l d6,end_x(gcb) {pass parms to vector generator} move.l d3,end_y(gcb) btst #7,d4 {ck control for move or draw} beq.s needmove movea.l draw(gcb),a0 { no static links } jsr (a0) bra next_vector NEEDMOVE equ * movea.l move(gcb),a0 { no static links } jsr (a0) NEXT_VECTOR equ * movem.l (sp)+,d0/d1/d5/d7/a0-a2/a4 {restore local state} TEST_VECTOR equ * * * Check for no vectors left *  dbra d5,VECTOR_LOOP * * Update CP * update_cp equ * clr.l d2 move a4,d2 move.l text_space_x(gcb),d1 movea.w d1,a3 cmpa.l d1,a3 bne range_error move.l text_space_y(gcb),d7 movea.w d7,a3 cmpa.l d7,a3 bne range_error muls d2,d1 muls d2,d7 asr.l #3,d1 asr.l #3,d7 add.l soft_text_temp1(gcb),d1 bvs range_error add.l soft_text_temp2(gcb),d7 bvs range_error UPDATE equ * move.l d1,current_pos_x(gcb) move.l d7,current_pos_y(gcb) bra NEXT_CHAR * control equ * add.w #32,d1 {restore character value} cmp.w #13,d1 { CR ? } beq.s C_return cmp.w #10,d1 { LF ? } beq.s L_feed cmp.w #8,d1 { BS ? } bne bad_char B_space equ * suba.l #2,a4 bra.s update_cp C_return equ * movea.l  #0,a4 move.l current_pos_x(gcb),d1 move.l current_pos_y(gcb),d7 move.l soft_text_temp1(gcb),d1 { restore cp to begining } move.l soft_text_temp2(gcb),d7 bra UPDATE { Update the CP and process next char } L_feed equ * * * Update local cp (d1,d7) * Update starting cp (temp1, temp2) * suba.l #1,a4 move.l current_pos_x(gcb),d1 move.l current_pos_y(gcb),d7 move.l text_line_x(gcb),d2 move.l text_line_y(gcb),d3 asr.l #3,d2 asr.l #3,d3 add.l d2,d1 { inc local cp } bvs range_error add.l d3,d7 bvs range_error add.l d2,soft_text_temp1(gcb) bvs range_error add.l d3,soft_text_temp2(gcb) bvs range_error bra UPDATE { Update the CP and process next char } DONE equ * unlk a6 move.l (sp)+,(sp) rts range_error ori #2,ccr  force overflow and let system process trapv bra.s done GLE_ASTEXT_GLE_ASTEXT rts  * * Pascal work station graphic library * scaling routine * * Module = DGL_AUTL * Programer = BJS * Date = 8/27/82 * * Purpose : To provide low level asmb routines for DGL * * * Rev history * * Created - 8-27-82 - BJS * Modified - 11-23-82 - BJS Removed ck for static link on proc calls * 2-10-82 - BJS Removed gcb, and proc var parms for performance * 6-27-83 - BJS Removed module init body, now in * module DGL_IBODY * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in *  DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * MNAME DGL_AUTL src module dgl_autl; src export src PROCEDURE dgl_scaled_move; src PROCEDURE dgl_scaled_draw; src end; * Define entry points rorg 0 def dgl_autl_dgl_autl def dgl_autl_dgl_scaled_move def dgl_autl_dgl_scaled_draw * Define externals refa dgl_vars lmode dgl_vars * Define ASMB control information nosyms * Define constants global equ a5 gle_gcb equ a3 * ** global variables * scale_factors equ dgl_vars-160 short_defaults equ dgl_vars-162 system_init equ dgl_vars-1 disp_init equ dgl_vars-2 loc_init equ dgl_vars-3 gle_gcb_def equ dgl_vars-186 include ASM_TYPES **************************************************************************** * * integer scale * * a0 -> display_offset d2 * window_delta d1 * display_delta d0 * * end_x := (end_x * display_delta) / window_delta + display_offset; * end_y := . . . * dgl_autl_dgl_scaled_draw equ *  movea.l gle_gcb_def(global),gle_gcb get gcb tst.b short_defaults(global) is scaling needed? bne.s done1 move.l end_x(gle_gcb),d6 lea scale_factors(global),a0 movem.w (a0)+,d0-d5 get scaling factors muls d0,d6 divs d1,d6 bvs.s tdb add.w d2,d6 ext.l d6 move.l d6,end_x(gle_gcb) move.l end_y(gle_gcb),d6 muls d3,d6 divs d4,d6 bvs.s tdb add.w d5,d6 ext.l d6 move.l d6,end_y(gle_gcb) done1 equ * move.l gle_gcb,-(sp) setup to pass gcb ptr movea.l draw(gle_gcb),a0 no static links jsr (a0) call draw rts dgl_autl_dgl_scaled_move equ * movea.l gle_gcb_def(global),gle_gcb get gcb tst.b short_defaults(global) is scaling needed? bne.s done2 move.l end_x(gle_gcb),d6 lea scale_factors(global),a0 movem.w (a0)+,d0-d5 get scaling factors muls d0,d6 divs d1,d6 bvs.s tdb add.w d2,d6 ext.l d6 move.l d6,end_x(gle_gcb) move.l end_y(gle_gcb),d6 muls d3,d6 divs d4,d6 bvs.s tdb add.w d5,d6 ext.l d6 move.l d6,end_y(gle_gcb) done2 equ * move.l gle_gcb,-(sp) setup to pass gcb ptr movea.l move(gle_gcb),a0 no static links jsr (a0) call draw  rts tdb trapv overflow rts ****************************************************************************** * dgl_autl_dgl_autl equ * rts end { } { Graphics Low End } { } { Module = DGL_CONF G_IN } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide selection of differnt input device handlers. } { Rev history } { Created - 10-10-82  } { Modified - 02-17-84 BDS - Changed from dynamic allocations to global } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $SEARCH 'GLE_LIB', 'TYPES', 'DGL_VARS', 'DGL_TOOLS', 'DGL_KNOB', 'DGL_HPGLI', 'DGL_HILI', 'D_HILREL'$ $modcal$ $include 'OPTIONS'$ { ***************** COMPILER OPTIONS **************** } $LINENUM 12000$ module DGL_CONFG_IN; import gle_types; export procedure configure_input_gle ( gcbi : graphics_input_control_block_ptr ); implement import gle_hpgl_in, { hpgl plotter support } gle_hpib_io, { plotter HPIB support } gle_knob_in, { knob support } gle_utls, { general gle tools } gle_hphil_absi, {hphil abs locator support SFB 3/29/85} gle_hphil_reli, {hphil rel locator support SFB 9/09/85} dgl_tools, { general gle and dgl tools } dgl_vars, { global dgl variables } dgl_types, { SFB 4/8/85 } sysglobals, { global pascal information } dgl_knob, { knob device dependent DGL code } dgl_hpgli, { plotter device dependent DGL code } dgl_hphil_absi, { DGL hphil abs locator support SFB 3/29/85 } dgl_hphil_reli, { DGL hphil rel locator support SFB 9/09/85 } sysdevs; { access to hphil data comm rec list SFB 3/29/85 } var ascii_buffer_space : ascii_buffer; knob_device_rec_space : knob_device_rec; hpib_iocb_space : hpib_iocb; hphil_rec_ptr : hphil_comm_rec_ptr_type; {SFB 3/29/85} function find_hphil_data_rec(dvrtype : integer) : hphil_comm_rec_ptr_type; var tlink : hphil_comm_rec_ptr_type; done : boolean; begin tlink := hphil_data_link; done := false; while (tlink <> nil) and (not done) do begin if tlink^.dvr_type = dvrtype then done := true else tlink := tlink^.link; end; find_hphil_data_rec := tlink; end; procedure termhphil_dvr ( anyvar iocb_ptr : anyptr ); {SFB 9/09/85} begin with hphil_rec_ptr^ do begin reading := true; active := false; reading := false; end; end; procedure setuphphil_rel ( gcbi : graphics_input_control_block_ptr ); {SFB 9/09/85} var address : integer; cnt : gle_shortint; begin with gcbi^ do begin error_return := 1; address := gle_read_integer(device_info_char_count,device_info,cnt); if (address = 202) and {SFB} HIL_PRESENT then begin hphil_rec_ptr := find_hphil_data_rec(rellocator); if hphil_rec_ptr <> NIL then begin io_term := termhphil_dvr; error_return := 0; gcbi^.info_ptr1 := hphil_rec_ptr; gle_init_hphil_rel_input(gcbi); if error_return = 0 then dgl_hphili_rel_init; end; end; end; end; procedure setuphphil_abs ( gcbi : graphics_input_control_block_ptr );{SFB 3/29/85} var address : integer; cnt : gle_shortint; begin with gcbi^ do begin error_return := 1; address := gle_read_integer(device_info_char_count,device_info,cnt); if (address = 201) and {SFB} HIL_PRESENT then begin hphil_rec_ ptr := find_hphil_data_rec(abslocator); if hphil_rec_ptr <> NIL then begin io_term := termhphil_dvr; error_return := 0; gcbi^.info_ptr1 := hphil_rec_ptr; gle_init_hphil_abs_input(gcbi); if error_return = 0 then dgl_hphili_abs_init;  end; end; end; end; procedure termknob ( anyvar iocb_ptr : anyptr ); var knob_rec : knob_device_rec_ptr; begin with gle_gcbi^ do begin knob_rec := dev_dep_stuff; end; end; procedure setupknob ( gcbi : graphics_input_control_block_ptr ); var knob_rec : knob_device_rec_ptr; cnt : gle_shortint; address : integer; begin with gcbi^ do begin address := gle_read_integer(device_info_char_count,device_info,cnt); if (address = 2) and (not sysflag.nokeyboard) then begin io_term := termknob; knob_rec := addr(knob_device_rec_space); dev_dep_stuff := knob_rec; knob_rec^.knob_type := return_machine_type; gle_init_knob_input ( gcbi); if error_return = 0 then dgl_knob_init; end else error_return := 1; end; end; procedure termhpgl ( anyvar iocb_ptr : anyptr ); var iocb_ptr_hpib : hpib_iocb_ptr; buf : ascii_buffer_ptr; begin with gle_gcbi^ do begin hpib_term(iocb_ptr); { perform io term then release mem } iocb_ptr_hpib := iocb; {dispose(iocb_ptr_hpib);} buf := device_buf; {dispose(buf);} end; end; procedure setuphpgl ( gcbi : graphics_input_control_block_ptr ); var iocb_ptr_hpib : hpib_iocb_ptr; buf  : ascii_buffer_ptr; cnt : gle_shortint; address : integer; begin with gcbi^ do begin error_return := 1; try address := gle_read_integer(device_info_char_count,device_info,cnt); buf := addr(ascii_buffer_space); device_buf := buf; iocb_ptr_hpib := addr(hpib_iocb_space); iocb := iocb_ptr_hpib; io_write := hpib_write; io_read := hpib_read; io_term := termhpgl; io_inq_timeout := hpib_inq_timeout; io_set_timeout := hpib_set_timeout; with iocb_ptr_hpib^ do begin device_addr := device_info; name_size := device_info_char_count; hpib_init ( iocb_ptr_hpib ); error_return := 0; if error = 0 then gle_init_hpgl_input (gcbi) else error_return := 1; if error_return = 0 then dgl_hpgli_init { otherwise clean up the hpib bus ( 2.1 bug fix ) } else hpib_init ( iocb_ptr_hpib ); end; recover { ignor io, and value range errors } if (escapecode <> -26) and (escapecode <> -8) then escape(escapecode); {if error_return <> 0 then begin} { clean up } {dispose(iocb_ptr_hpib); dispose(buf); end;} end; end; procedure configure_input_gle ( gcbi : graphics_input_control_block_ptr ); begin setupknob ( gcbi ); if gcbi^.error_return <> 0 then setuphpgl ( gcbi ); if gcbi^.error_return <> 0 then setuphphil_abs ( gcbi ); {SFB 3-29-85} if gcbi^.error_return <> 0 then setuphphil_rel ( gcbi ); {SFB 9-09-85} end; end. { of module } { } { Graphics Library } { } { Module = DGL_CONFG_OUT } { Programer = BJS } { Date = 10- 5-82 } {  } { Purpose: To link device dependent drivers with the graphics library. } { Rev history } { Created - 10- 5-82  } { Modified - 1-12-84 BDS -Added Gator black-white support } { Modified - 2-17-84 BDS -Changed dynamic to global storage for PASC 3.0 } { Modified - 7-01-85 SFB -Changes to support Bobcat/Gatorbox } { Modifi ed - 7-19-85 BJS -Changes to fix check for moonunit address. } { Modified - 11JUN91 CFB -Added WOODCUT graphics support } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $MODCAL$ $SEARCH 'GLE_LIB', 'TYPES', 'DGL_VARS', 'DGL_TOOLS', 'DGL_RAS', 'DGL_HPGL'${} $modcal$ $include 'OPTIONS'$ { compiler options } $LINENUM 11000$ module DGL_CONFG_OUT; import gle_types, sysdevs; export procedure configure_gle ( gcb : graphics_control_block_ptr ); implement import gle_hpgl_out, { hpgl plotter support } gle_ras_out, { raster support } gle_file_io, { plotter spooling io } gle_hpib_io, { plotter HPIB support } gle_utls, { general tools } dgl_tools, { used to get machine type } sysglobals, { address for GRAPHICSBASE } iodeclarations, { used to get min, max selectcode ranges } gle_autl, { for GLE_IAND } dgl_raster, { DGL device dependent raster init code } dgl_hpgl, { DGL device dependent HPGL init code } dgl_vars; { DGL global data } var save_crthook: crtlltype; hp98627A_address : anyptr; { holds adr of first graphics plane } found_bitmap: boolean; select_code : shortint; has_color : boolean; frame_buffer : integer; stat : ^shortint; ptr: ^shortint; int_ext_bitmap : shortint; { 0=no bitmap display, 1=internal GATOR, 2=external GATOR, 3=internal GATORBOX,4=external GATORBOX,  5=internal BOBCAT, 6=external BOBCAT, 7=int LO-RES BOB, 8=ext LORES BOB, 9=int LCC CATSEYE, 10=ext LCC CATSEYE additions 9/09/86 SFB 11=int HRx CATSEYE, 12=ext HRx CATSEYE more additions 2/19/88 SFB 13=int VGA WOODCUT, 14=ext VGA WOODCUT 15=int Med WOODCUT, 16=ext Med WOODCUT 17=int Hrx WOODCUT, 18=ext Hrx WOODCUT more additions 7JUN91 CFB greyscale 19=int VGA WOODCUT, 20=ext VGA WOODCUT 21=int Med WOODCUT, 22=ext Med WOODCUT more additions 30JUL91 CFB } raster_device_rec_space : raster_device_rec; hpgl_device_rec_space : hpgl_device_rec; ascii_buffer_space : ascii_buffer; file_iocb_space : file_iocb; hpib_iocb_space : hpib_iocb; took_type_ahead : boolean; reduced_screen : boolean; secondary : boolean; moon : boolean; sysflg2[hex('FFFFFEDA')]: packed record bit7, bit6, bit5, bit4,  bit3, bit2, bit1, bit0 : boolean; end; procedure termraster ( anyvar iocb_ptr : anyptr ); var charvar : char; begin with gle_gcb^ do begin if reduced_screen then begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do  begin reduced_screen := true; n_glines := 752; hard_ymax := 751; end; end; if took_type_ahead then begin crtllhook := save_crthook; keybufops(kdisplay,charvar); end; end; end; {Look for bitmap display present. Assume only one is on the bus and that an internal one overrides an external one if multiples present.} procedure bitmapcrttype(var found_bitmap,has_color:boolean; var frame_buffer :integer; var select_code,int_ext_bitmap :shortint; var cmapid : integer); {ADDED SFB--6/11/85} const {added 2/19/88 SFB} Gator_tertiary = 0; Gbox_tertiary = 1; Bobcat_tertiary = 2; unsupp1_tertiary = 3; unsupp2_tertiary = 4; LCC_tertiary = 5; HRC_tertiary   = 6; HRM_tertiary = 7; unsupp3_tertiary = 8; unsupp4_tertiary = 9; unsupp5_tertiary = 10; unsupp6_tertiary = 11; unsupp7_tertiary = 12; unsupp8_tertiary = 13; unsupp9_tertiary = 14; Hrx_Woodcut_tertiary = 15; Med_Woodcut_tertiary = 16; VGA_Woodcut_tertiary = 17; VGAM_Woodcut_tertiary= 18; { Mono Versions of VGA and HRX - 30JUL91 CFB } HrxM_Woodcut_tertiary= 19; Gbox_int_ext = 3; Bobcat_int_ext = 5;  unsupp_int_ext = 0; LCC_int_ext = 9; HRx_int_ext = 11; VGA_Woodcut_int_ext = 13; Med_Woodcut_int_ext = 15; Hrx_Woodcut_int_ext = 17; VGAM_Woodcut_int_ext = 19; HrxM_Woodcut_int_ext = 21; const gatorid =25; bitmapid =57; { SFB 10-10-84 } low_id = Gbox_tertiary; {GATORBOX; added 9/09/86 SFB} hi_id = HrxM_Woodcut_tertiary; {WOODCUT; changed 30JUL91 CFB} type  int_ext_type = (int,ext); iptr = ^integer; tertiary_ids = array[low_id..hi_id] of shortint; const {map to various int_ext_values} {added WOODCUT 7JUN91 CFB} supported_tertiaries = tertiary_ids[Gbox_int_ext, Bobcat_int_ext,  unsupp_int_ext, unsupp_int_ext, LCC_int_ext, HRx_int_ext, HRx_int_ext, unsupp_int_ext, unsupp_int_ext, unsupp_int_ext, unsupp_int_ext, unsupp_int_ext, unsupp_int_ext, unsupp_int_ext, Hrx_Woodcut_int_ext, Med_Woodcut_int_ext, VGA_Woodcut_int_ext, VGAM_Woodcut_int_ext, HrxM_Woodcut_int_ext]; {hi_int_ext=supported_tertiaries[hi_id]+1; {compiler doesn't support this.} {2/19/88 SFB} var i : shortint; dummy : shortint; bptr : ^char; procedure setupbitmaptype(int_ext : int_ext_type); var fbrelative : integer; tvalue : shortint; {SFB 9/09/86} function value : shortint; {returns value of byte at bptr^ in GRAPHICS  ROM and bumps bptr to next byte} begin value := ord(bptr^); bptr := anyptr(integer(bptr) + 2); end; begin if dummy = gatorid then begin int_ext_bitmap := 1 + ord(int_ext); stat := anyptr(control_space + 16384); frame_buffer := ((stat^) mod 16)*hex('100000'); end else begin {read tertiary ID and locate frame buffer} bptr := anyptr(control_space + 21); tvalue := value;  {SFB 9/09/86} {int_ext_bitmap := 2 * value + ord(int_ext) + 1;} if (tvalue >= low_id) and (tvalue <= hi_id) then {SFB 9/09/86} begin int_ext_bitmap := supported_tertiaries[tvalue]; if int_ext_bitmap <> 0 then int_ext_bitmap := int_ext_bitmap + ord(int_ext); end; if (int_ext_bitmap >= Gbox_int_ext) and (int_ext_bitmap < VGA_Woodcut_int_ext) then {CFB 7JUN91} begin {SFB 1-23-85} bptr := anyptr(control_space + hex('005D')); {^frame buffer relative location pointer--2 byte qty} fbrelative := value; fbrelative := value + fbrelative * 256; bptr := anyptr(fbrelative + control_space); {bits A16..A23 of frame buffer address} frame_buffer := value * hex('10000'); {left shift bits 16..23 by 16 places} {check for lo-res bobcat} if (int_ext_bitmap = 5) or (int_ext_bitmap = 6) then begin bptr := anyptr(control_space + hex('0017'));{^"non-square pixel" info} if odd(ord(bptr^)) then int_ext_bitmap := int_ext_bitmap + 2; {set to corresponding lores internal or external bobcat type} end else {GATORBOX added SFB--6/11/85} begin  {get colormap id for later use SFB--6/11/85} bptr := anyptr(control_space + hex('57')); {cmapid addr pointer} fbrelative := value; {MSB of rel address} fbrelative := value + 256*fbrelative;   {16-bit rel address} bptr := anyptr(control_space + fbrelative); {cmapid addr} cmapid := value mod 4; {at last! the cmapid 2 lower bits} end; end; {if (int_ext_bitmap >= VGA_Woodcut_int_ext) and *****{DIO-II is different} if (int_ext_bitmap >= LCC_int_ext) and {DIO-II is different} (int_ext_bitmap <= HrxM_Woodcut_int_ext+1) and (control_space >= hex('1000000')) then begin frame_buffer := control_space + hex('200000'); cmapid := 99; end; end; end; begin control_space:=0; found_bitmap:=false; int_ext_bitmap := 0; ptr:=anyptr(hex('560000')); cmapid := 0; {SFB 6/11/85} if select_code <= 6 then {only check internal space SFB 7/9/85} try dummy := ptr^; dummy := dummy mod 128; if (dummy = gatorid) OR (dummy = bitmapid) then {found internal bitmap} begin found_bitmap:=true; control_space:=integer(ptr); end; recover begin {add WOODCUT console support - CFB 13JUN91} if escapecode<>-12 then escape(escapecode); if (sysflg2.bit4 = true) then {don't try on 68000/68010 - CFB 1APR92} begin ptr:=anyptr((hex('1000000'))); {try SC 132 for console}  try dummy:=ptr^; dummy := dummy mod 128; if (dummy = bitmapid) then begin found_bitmap:=true; control_space:=integer(ptr); end; recover if escapecode<>-12 then escape(escapecode); end; end; if found_bitmap then  {if there, find frame buffer} setupbitmaptype(int) else if (select_code >= 8) and (select_code <= 31) then {modified CFB 7JUN91} begin ptr:=anyptr(hex('600000')+select_code*(hex('10000'))); try dummy:=ptr^;  dummy := dummy mod 128; if (dummy = gatorid) OR (dummy = bitmapid) then begin found_bitmap:=true; control_space:=integer(ptr); end; recover if escapecode<>-12 then escape(escapecode); if found_bitmap then setupbitmaptype(ext); end else if (select_code >= 132) and (sysflg2.bit4 = true) then { added DIO-II CFB 7JUN91 / added sysflag2 test CFB 3OCT91 } begin ptr:=anyptr((select_code-128)*(hex('400000'))); {SC 132 starts at 16 Meg} try  dummy:=ptr^; dummy := dummy mod 128; if (dummy = bitmapid) then begin found_bitmap:=true; control_space:=integer(ptr); end; recover if escapecode<>-12 then escape(escapecode); if found_bitmap then setupbitmaptype(ext); { always external } end; end; procedure setupraster ( gcb : graphics_control_block_ptr ); var graphics_base ['GRAPHICSBASE'] : anyptr; device_work_area : raster_device_rec_ptr; cnt : gle_shortint; address : integer; control : integer; knob_echo_gcb : boolean; g_ptr : ^shortint; g_dummy : shortint; graphics_bd : boolean; graphicstate ['GRAPHICSFLAG'] : boolean; cmapid : integer; {SFB 6/11/85} procedure dummy1 ( anyvar iocb_ptr, data_ptr : anyptr ); begin end; procedure expand_screen; begin with gcb^ do begin info3 := 0; if (int_ext_bitmap <> 0) then begin reduced_screen := false; info3 := 1;  {1=expand; 0=leave reduced} end; {send on to expand screen} end; if (currentcrt = bitmaptype) and (odd(int_ext_bitmap)) and {SFB 3/27/85 to prevent locator destroying save_crthook} (not knob_echo_gcb) then begin save_crthook := crtllhook; crtllhook := dummycrtll; took_type_ahead := true; end; end; procedure ck_for_graphics_board; begin graphics_bd := true; if graphicstate then g_ptr := anyptr(hex('530000')) else g_ptr := anyptr(hex('538000')); try g_dummy := g_ptr^; recover begin if escapecode <> -12 then escape(escapecode) else graphics_bd := false; end; end; procedure setup_internal; procedure toggle_graphic s; var gon [5439488 {530000 HEX}] : shortint; goff [5472256 {538000 HEX}] : shortint; g_on36c [ hex('51FFFC')]: shortint; gbase['GRAPHICSBASE'] : ^shortint; begin if gcb^.info1 = m9836c then begin if graphicstate then g_on36c:=1 else g_on36c:=0; gbase:=anyptr(hex('520000')); end else begin if graphicstate then gbase := addr(gon) else gbase := addr(goff); gbase^ := gbase^; end; end; begin with gcb^ do begin graphicstate := true; info1 := return_machine_type; toggle_graphics; info_ptr1 := addr(graphics_base); info_ptr2 := anyptr(0); if info1 = m9836c then begin info2 := hex('51fffd'); info3 := hex('51fb00'); end; end; end; procedure set_moon_vals; begin with gcb^ do begin info3 := control div 256; { get monitor type information (part of control) } if (info3 > 6) or (info3 < 1) then info3 := 1; moon := true; info1 := m98627a; { set display type to 98627A } info2 := address * 65536 + 6291456; { i/o card address } hp98627a_address := anyptr(info2 + hex('8000')); { first plane adr } info_ptr1 := addr(hp98627a_address); info_ptr2 := anyptr(0); end; end; procedure set_bitmap_vals; begin with gcb^ do begin info2 := control_space; {top of control space} info3 := 0; {By default dont expand ! BJS 5-29-84} info4 := cmapid; {for gle_raster_init gatorbox SFB 6/11/85} info_ptr1 := addr(frame_buffer); {start of control space} info_ptr2 := anyptr(0); case (int_ext_bitmap-1) div 2 of 0 : info1 := m9837a; 1 : info1 := mgatorbox; 2 : info1 := mbobcat; 3 : info1 := mbobcatlores; 4 : info1 := mcatseye; {SFB 9/09/86} 5 : info1 := mcatseye_hrx; {SFB 2/23/88} 6 : info1 := mvga_woodcut; {CFB 7JUN91} 7 : info1 := mmed_woodcut; {CFB 7JUN91} 8 : info1 := mhrx_woodcut; {CFB 7JUN91} 9 : info1 := mvgam_woodcut; {CFB 30JUL91} 10 : info1 := mhrxm_woodcut; {CFB 30JUL91} otherwise begin end; {SFB 2/23/88} end; end; end; begin with gcb^ do if spooling = 0 then try {address computaton moved up SFB 7/9/85} address := gle_read_integer(device_info_char_count,device_info,cnt); select_code := address; {SFB 7/9/85} bitmapcrttype(found_bitmap, has_color, frame_buffer, select_code, int_ext_bitmap, cmapid {added SFB 6/11/85}); ck_for_graphics_board; {some how this was commented out at 54.2 - CFB} secondary := false; moon := false; reduced_screen := true; control := info1; { control passed in info1 } knob_echo_gcb := (info2 = 1); { GCB for knob echos } if not knob_echo_gcb then {SFB 6/25/85} took_type_ahead := false; io_write := dummy1; io_term := termraster; device_work_area := addr(raster_device_rec_space); dev_dep_stuff := device_work_area; if address = 3 then {indicates primary display} begin if ((currentcrt = alphatype) or (currentcrt = nocrt)) and (graphics_bd) then setup_internal else if ((currentcrt = bitmaptype) or (not graphics_bd)) {and (odd(int_ext_bitmap))} then {removed for WOODCUT - CFB 13JUN91} set_bitmap_vals; end else if (address = 6) then {indicates secondary display} begin secondary := true; if ((currentcrt = alphatype) or (currentcrt = nocrt)) {JWS 7/23/85} and (int_ext_bitmap <>0) then set_bitmap_vals else if (graphics_bd) then setup_internal; if (currentcrt = bitmaptype) then {console = bitmap so} begin {set secondary to} { small screen} if (graphics_bd) then  setup_internal else {if fails set second.} if (odd(int_ext_bitmap)) then {to bitmap.} set_bitmap_vals; end; end else { must be moonunit or external bitmap } begin if (addre ss < minrealisc) or ((address > maxrealisc) and (address < 132)) or {add DIO-II CFB 9JUN91} ((address >= 132) and (sysflg2.bit4 = false)) then { added sysflag2 test to fix bug on 68000/68010 CFB 1APR92} escape(1); {Replaced following line BJS 7-23-85; address will always be equal to select_code since 7-9-85 bug fix. Determine if a bit map by looking at int_ext_bitmap being equal to 0 } {if (address = select_code) and (not odd(int_ext_bitmap)) then} if ((int_ext_bitmap <> 0) and (not odd(int_ext_bitmap))) then set_bitmap_vals else set_moon_vals; end; {control set} if (odd(control DIV 256)) and (not moon) then if ((currentcrt = bitmaptype) and (odd(int_ext_bitmap)) and {is bitmap, primary, } (not secondary)) { bitmap is there } or { or } (((currentcrt = alphatype) or (currentcrt = nocrt)) and {is alpha/none,gr bd, } (graphics_bd) and (secondary) and (odd(int_ext_bitmap))) {second,bitmap there } or { or } (address > 6) and (not odd(int_ext_bitmap)) {ext. bitmap there } then expand_screen; {control not set, but bitmap is not console} if (((currentcrt = alphatype) or (currentcrt = nocrt)) and (int_ext_bitmap <>0) and (secondary)) or (((currentcrt = alphatype) or (currentcrt = nocrt)) and (not graphics_bd) and (int_ext_bitmap <>0)) or  ((address >= 8) and (address < 32) and (not moon)) {SFB 7/10/85} {jws 6/18/86} {CFB 13JUN91} then expand_screen; gle_init_raster_output (gcb); if (error_return = 0) and (not knob_echo_gcb) then dgl_raster_init(control); {if error_return <> 0 then dispose(device_work_area);} { clean up } recover { ignore all escapes (except stop key), user may look at escapecode to determine error } if escapecode = -20 then escape(-20) else error_return := 1 else error_return := 1; { raster devices may not be spooled } end; procedure termhpgl ( anyvar iocb_ptr : anyptr ); var iocb_ptr_file : file_iocb_ptr; iocb_ptr_hpib : hpib_iocb_ptr; buf : ascii_buffer_ptr; device_work_area : hpgl_device_rec_ptr; save_ioresult : integer; { | fix clobbering ioresult -- 12/83} begin with gle_gcb^ do begin if spooling <> 0 then begin save_ioresult := ioresult; { | ioresult problem fix 12/83--BDS} file_term(iocb_ptr); { perform io term then release mem } ioresult := save_ioresult; { | ioresult problem fix 12/83--BDS} iocb_ptr_file := iocb; {dispose(iocb_ptr_file);} end else begin hpib_term(iocb_ptr); { perform io term then release mem } iocb_ptr_hpib := iocb; {dispose(iocb_ptr_hpib);} end; buf := device_buf; device_work_area := dev_dep_stuff; {dispose(buf); dispose(device_work_area);} end; end; procedure setuphpgl ( gcb : graphics_control_block_ptr ); var iocb_ptr_file : file_iocb_ptr; iocb_ptr_hpib : hpib_iocb_ptr; buf : ascii_buffer_ptr; device_work_area : hpgl_device_rec_ptr; cnt : gle_shortint; address : integer; address_found : boolean; control : integer; save_ioresult : integer; { | fix clobbering ioresult -- 12/83} save : integer; begin with gcb^ do begin control := info1; { control passed in info1 } address_found := false; try address := gle_read_integer(device_info_char_count,device_info,cnt); address_found := true; recover if escapecode <> -8 { value range error } then escape(escapecode); buf := addr(ascii_buffer_space); device_buf := buf; device_work_area := addr(hpgl_device_rec_space); dev_dep_stuff := device_work_area; if spooling = 1 then begin iocb_ptr_file := addr(file_iocb_space); iocb := iocb_ptr_file; io_write := file_write; io_term := termhpgl;   io_inq_timeout := file_inq_timeout; io_set_timeout := file_set_timeout; with iocb_ptr_file^ do begin file_name := device_info; name_size := device_info_char_count; try lock_on_close := 0; { do not save file by default } file_init ( iocb_ptr_file ); gle_init_hpgl_output (gcb); if error_return = 0 then begin dgl_hpgl_init(control); lock_on_close := 1; { save file } end else begin save_ioresult := ioresult; {| ioresult fix 12/83--BDS} file_term ( iocb_ptr_file ); ioresult := save_ioresult; {| ioresult fix 12/83--BDS} end; recover if escapecode <> -10 then escape(escapecode) else error_return := 1; end;  if error_return <> 0 then begin { clean up } save_ioresult := ioresult; {| ioresult fix 1/84--BDS} {dispose(iocb_ptr_file); dispose(buf); dispose(device_work_area);} ioresult := save_ioresult; {| ioresult fix 1/84--BDS} end; end else if address_found then begin iocb_ptr_hpib := addr(hpib_iocb_space); iocb := iocb_ptr_hpib; io_write := hpib_write; io_read := hpib_read; io_term := termhpgl; io_inq_timeout := hpib_inq_timeout; io_set_timeout := hpib_set_timeout; with iocb_ptr_hpib^ do begin device_addr := device_info; name_size := device_info_char_count; end; hpib_init ( iocb_ptr_hpib ); if iocb_ptr_hpib^.error = 0 then begin gle_init_hpgl_output (gcb); if error_return = 0 then dgl_hpgl_init(control) { if error then clean up hpib bus (2.1 bug fix) } else hpib_init ( iocb_ptr_hpib ); end else error_return := 1; if error_return <> 0 then begin { clean up } {dispose(iocb_ptr_hpib); dispose(buf); dispose(device_work_area);} end; end else error_return := 1; end; end; procedure configure_gle ( gcb : graphics_control_block_ptr ); begin with gcb^ do begin setupraster ( gcb ); if error_return <> 0 then setuphpgl ( gcb ); end; end; end. { of module } { } { DGL device dependent init routine } { } { Module = DGL_HPHIL_ABSI } { Programer = SFB } { Date = 3 -25-85 } {  } { Purpose: To provide device dependent initialization for HPHIL TABLET } { Rev history } { Created - 3 -25-85 SFB  } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS', 'GEN', 'DGL_C_OUT'$ $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 18000$ module DGL_HPHIL_ABSI; export procedure dgl_hphili_abs_init; implement import dgl_types, dgl_vars, gle_types, gle_gen, gle_geni, dgl_gen; procedure hphil_abs_sample_locator( echo : integer;   var rx,ry : real ); { Purpose : To sample the locator device } var dx, dy : integer; begin with gle_gcbi^ do begin gle_sample(gle_gcbi); convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); info1 := echo; gle_input_echo (gle_gcbi); { echo on locator device } end; end; { sample_locator } procedure hphil_abs_await_locator(var echo : integer; var button : integer; var rx,ry : real ); { Purpose : To activate the locator, and wait for operator termination } var echoerror : boolean; dx,dy : integer; last_x,last_y : integer; begin if (echo < 0) or (echo > 8) then echo := 1; { ck echo range } { ck for display echo, and display not enabled } if (not disp_init) and (echo >1) then begin echoerror := true; echo := 1; end else echoerror := false; with gcb^,gle_gcbi^ do begin current_echo_type := echo; info2 := 0; gle_start_digitize (gle_gcbi); last_x := -32768; last_y := -32768; if echo > 1 then with gle_gcb^ do begin info1 := d_loc_echo_x; info2 := d_loc_echo_y; info3 := 1; { on } gle_cursor ( gle_gcb ); { perform first echo at lep }  end; repeat gle_sample ( gle_gcbi ); convert_ltod(info1,info2,dx,dy); button := info3; if (dx <> last_x) or (dy <> last_y) then begin last_x := dx; last_y := dy; if (echo > 1) and (not disp_eq_loc) then with gle_gcb^ do begin info1 := dx; info2 := dy; info3 := 1; gle_cursor ( gle_gcb ); end; end; until button <> -1; gle_get_digitize(gle_gcbi); button := info3; convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); adjust_return_echo ( rx, ry ); if echo > 1 then with gle_gcb^ do begin info3 := 0; gle_cursor(gle_gcb); { remove cursor from screen } end; if echo = 1 then begin info1 := echo; gle_input_echo ( gle_gcbi ); end; end; if echoerror then error (err_echo_dis_int); end; { await_locator } procedure dgl_hphili_abs_init; begin with gcb^ do begin proc_await_locator := hphil_abs_await_locator; proc_sample_locator := hphil_abs_sample_locator; end; end; end. { dgl_hphili_abs_init } { } { DGL device dependent init routine } { } { Module = DGL_HPGL } { Programer = BJS } { Date = 10- 5-82 } {  } { Purpose: To provide device dependent initialization for HPGL devices. } { Rev history } { Created - 1 - 5-82 BJS  } { Modified - 4 -03-84 BDS Changes dynamic allocations to globals for 3.0 } { Added identifiers for 7586,7550,7475 } { Modified - 4 -85 SFB Added calls to locator_esc } { Modified - 5 -87 SFB Fixed pen_force and accleration for last pen } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technica l Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS'$ $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 17000$ module DGL_HPGL; export procedure dgl_hpgl_init(control : integer); implement import dgl_types, dgl_vars, gle_gen, gle_utls, asm; procedure hpgl_input_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); { Purpose : To perform an input escape function } var s : string[40];  cnt : integer; c : char; begin with gle_gcb^ do begin if spooling = 1 then ierr := 4; if ((gle_match(4,addr(display_name),4,addr('7580')) or gle_match(4,addr(display_name),4,addr('7570')) or {SFB 9/18/86} gle_match(4,addr(display_name),4,addr('7550')) or gle_match(4,addr(display_name),4,addr('7475')) or gle_match(4,addr(display_name),4,addr('7090')) or gle_match(4,addr(display_name),4,addr('7585')) or gle_match(4,addr(display_name),4,addr('7586')) or gle_match(4,addr(display_name),4,addr('7595')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7596')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7575')) or {SFB 11/14/88} gle_match(4,addr(display_name),4,addr('7576')))) and {SFB 11/14/88} (opcode = 2050) then begin if (ierr = 0) then begin info_ptr1 := addr('OT'); info1 := 2; gle_output_escapeo( gle_gcb ); gle_flush_buffer (gle_gcb); info_ptr1 := addr(s[1]); gle_output_escapei ( gle_gcb ); setstrlen(s,info1); strread(s,1,cnt,ilist[1],c,ilist[2]); end; end else ierr := 1; end; {CALL ADDED 4/10/85 SFB} call(gcb^.proc_locator_input_esc, opcode, isize, rsize,  ilist, rlist, ierr); {give locator a chance at opcode SFB 4/10/85} end; { input_esc } procedure hpgl_output_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list;  var ierr : integer ); { Purpose : To perform an output escape funtion } var s : string[20]; cnt : integer; procedure set_auto_pen; begin strwrite(s,1,cnt,'AP',ilist[1]:1); end; procedure control_cutter; begin s := 'EC'; if ilist[1] = 0 then begin setstrlen(s,3); s[3] := '0'; end; end; procedure advance_page; begin if ilist[1] = 0 then s := 'AH' else s := 'AF'; end; procedure set_velocity; begin strwrite(s,1,cnt,'VS',ilist[1]:1); if (ilist[2] > 0) and (ilist[2] <= gle_gcb^.gamut) then strwrite(s,cnt,cnt,',',ilist[2]:1); end; procedure set_force; begin strwrite(s,1,cnt,'FS',ilist[1]:1); if (ilist[2] > 0) and (ilist[2] <= gle_gcb^.gamut) then {changed above from "<" to "<=" for STARS bug SR#1650022251 5-20-87 SFB} strwrite(s,cnt,cnt,',',ilist[2]:1); end; procedure set_acceleration; begin strwrite(s,1,cnt,'AS',ilist[1]:1); if (ilist[2] > 0) and (ilist[2] <= gle_gcb^.gamut) then {changed above from "<" to "<=" for STARS bug SR#1650022251 5-20-87 SFB} strwrite(s,cnt,cnt,',',ilist[2]:1); end; begin with gle_gcb^ do begin s := ''; if gle_match(4,addr(display_name),4,addr('9872')) then begin if (opcode = 1052) then begin if (ierr = 0) then control_cutter; end else if (opcode = 1053) then begin if (ierr = 0) then advance_page; end else if (opcode = 2050) then begin if (ierr = 0) then set_velocity; end  else ierr := 1; end else if ((gle_match(4,addr(display_name),4,addr('7470'))) or (gle_match(4,addr(display_name),4,addr('7440')))) then begin if (opcode = 2050) then begin if (ierr = 0) then set_velocity; end else ier r := 1; end else if (gle_match(4,addr(display_name),4,addr('7580')) or gle_match(4,addr(display_name),4,addr('7570')) or {SFB 9/18/86} gle_match(4,addr(display_name),4,addr('7550')) or gle_match(4,addr(display_name),4,addr('7475')) or gle_match(4,addr(display_name),4,addr('7090')) or gle_match(4,addr(display_name),4,addr('7585')) or gle_match(4,addr(display_name),4,addr('7586')) or gle_match(4,addr(display_name),4,addr('7595')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7596')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7575')) or {SFB 11/14/88} gle_match(4,addr(display_name),4,addr('7576'))) then {SFB 11/14/88} begin if (opcode = 1052) then begin if (ierr = 0) then set_auto_pen; end else if ((opcode = 1053) and ((gle_match(4,addr(display_name),4,addr('7586'))) or ((gle_match(4,addr(display_name),4,addr('7596'))) or {SFB 9/22/86} (gle_match(4,addr(display_name),4,addr('7550')))))) then begin if (ierr = 0) then advance_page; end else if (opcode = 2050) then begin if (ierr = 0) then set_velocity; end else if (opcode = 2051) then begin if (ierr = 0) then set_force; end else if (opcode = 2052) then begin if (ierr = 0) then set_acceleration; end else ierr := 1; end else ierr := 1; if ierr = 0 then begin info_ptr1 := addr(s[1]); info1 := strlen(s); gle_output_escapeo(gle_gcb); end; end; {CALL ADDED SFB 4/10/85} call(gcb^.proc_locator_output_esc, opcode, isize, rsize, ilist, rlist, ierr); {give locator a chance at opcode SFB 4/10/85} end; { output_esc } procedure hpgl_linestyle ( index : integer); { Purpose: To set the linestyle that primitives are drawn with } type ls_map_def = packed array [1..13] of gbyte; const ls_map = ls_map_def [0,2,3,4,5,6,1,2,3,4,5,6,1]; begin with gle_gcb^ do begin info1 := ls_map[index]; { map DGL to GLE def } info2 := 4; { repeat rate 4% } if (index > 7) then info3 := 1 else info3 := 0; { linestyle mode } info4 := 0; gle_linestyle ( gle_gcb ); end; end; { hpgl_linestyle } procedure hpgl_color ( index : integer ); begin gle_gcb^.info1 := index; gle_index_color ( gle_gcb ); end; procedure hpgl_color_table ( index : integer; parm1 : real; parm2 : real; parm3 : real); begin end; procedure dgl_hpgl_init(control : integer); type default_poly_table_def = array[1..16] of poly_entry_def; const default_poly_table = default_poly_table_def [ poly_entry_def [ density : 0.0 , orient : 0.0, edge : true ], { 1 } poly_entry_def [ density : 0.125, orient : 90.0, edge : true ], { 2 } poly_entry_def [ density : 0.125, orient : 0.0, edge : true ], { 3 } poly_entry_def [ density : -0.125, orient : 0.0, edge : true ], { 4 } poly_entry_def [ density : 0.125, orient : 45.0, edge : true ], { 5 } poly_entry_def [ density : 0.125, orient : -45.0, edge : true ], { 6 } poly_entry_def [ density : -0.125, orient : 45.0, edge : true ], { 7 } poly_entry_def [ density : 0.25 , orient : 90.0, edge : true ], { 8 } poly_entry_def [ density : 0.25 , orient : 0.0, edge : true ], { 9 } poly_entry_def [ density : -0.25 , orient : 0.0, edge : true ], { 10 } poly_entry_def [ density : 0.25 , orient : 45.0, edge : true ], { 11 } poly_entry_def [ density : 0.25 , orient : -45.0, edge : true ], { 12 } poly_entry_def [ density : -0.25 , orient : 45.0, edge : true ], { 13 } poly_entry_def [ density : -0.5 , orient : 0.0, edge : true ], { 14 } poly_entry_def [ density : 1.0 , orient : 0.0, edge : false], { 15 } poly_entry_def [ density : 1.0 , orient : 0.0, edge : true ]];{ 16 } type control_def = packed record case gshortint of 0 : (whole : gshortint); 1 : (part : packed record b15,b14,b13,b12, b11,b10,b9, b8, clr_inhibit,b6,b  5,b4, b3,b2,b1,b0 : boolean; end); end; var temp_control : control_def; i : integer; begin with gcb^ do begin disp_just := lowerleft; clipping_support := true; retroactive_color_support := false; retroactive_polygon_support := false; maximum_polygon_vertices := 0; { no hardware support } if gle_gcb^.vect_linestyles <> 0 then number_dgl_linestyles := 13 else number_dgl_linestyles := 7; number_markers := 19; proc_output_esc := hpgl_output_esc; proc_input_esc := hpgl_input_esc; proc_linestyle := hpgl_linestyle; proc_color := hpgl_color; proc_color_table := hpgl_color_table; color_table_size := 0; { allocate polygon table space } number_polygon_styles := 16; {newbytes(poly_table_ptr,number_polygon_styles * 18);} poly_table_ptr := addr(poly_table_def_space); for i := 1 to poly_table_size do poly_table_ptr^[i] := default_poly_table[i]; display_echo_mult := 8; temp_control.whole := control; if not temp_control.part.clr_inhibit then with gle_gcb^ do begin info1 := -1; { clear all planes } info2 := dgl_background_index; gle_clear ( gle_gcb ); end; end; end; end. { dgl_hpgl } { } { DGL device dependent init routine } { } { Module = DGL_HPGLI } { Programer = BJS } { Date = 2 -10-83 } {  } { Purpose: To provide device dependent initialization for the knob. } { Rev history } { Created - 2 -10-82 BJS  } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS', 'GEN', 'DGL_C_OUT'$ $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 18000$ module DGL_HPGLI; export procedure dgl_hpgli_init; implement import dgl_types, dgl_vars, gle_types, gle_gen, gle_geni, dgl_gen; procedure hpgli_sample_locator( echo : integer; var rx,ry : real ); { Purpose : To sample the locator device } var dx, dy : integer; begin with gle_gcbi^ do begin gle_sample(gle_gcbi); convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); info1 := echo; gle_input_echo (gle_gcbi); { echo on locator device } end; end; { sample_locator } procedure hpgli_await_locator(var echo : integer;  var button : integer; var rx,ry : real ); { Purpose : To activate the locator, and wait for operator termination } var echoerror : boolean; dx,dy : integer; last_x,last_y : integer; begin if (echo < 0) or (echo > 8) then echo   := 1; { ck echo range } { ck for display echo, and display not enabled } if (not disp_init) and (echo >1) then begin echoerror := true; echo := 1; end else echoerror := false; with gcb^,gle_gcbi^ do begin current_echo_type := echo; info2 := 0; gle_start_digitize (gle_gcbi); last_x := -32768; last_y := -32768; if echo > 1 then with gle_gcb^ do begin info1 := d_loc_echo_x; info2 := d_loc_echo_y; info3 := 1; { on } gle_cursor ( gle_gcb ); { perform first echo at lep } end; repeat gle_sample ( gle_gcbi ); convert_ltod(info1,info2,dx,dy); button := info3; if (dx <> last_x) or (dy <> last_y) then begin last_x := dx; last_y := dy;  if (echo > 1) and (not disp_eq_loc) then with gle_gcb^ do begin info1 := dx; info2 := dy; info3 := 1; gle_cursor ( gle_gcb ); end; end; until button = -1; gle_get_digitize(gle_gcbi); button := info3;  convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); adjust_return_echo ( rx, ry ); if echo > 1 then with gle_gcb^ do begin info3 := 0; gle_cursor(gle_gcb); { remove cursor from screen } end; if echo = 1 then begin info1 := echo; gle_input_echo ( gle_gcbi ); end; end; if echoerror then error (err_echo_dis_int); end; { await_locator } procedure dgl_hpgli_init; begin with gcb^ do begin proc_await_locator := hpgli_await_locator; proc_sample_locator := hpgli_sample_locator; end; end; end. { dgl_hpgli_init } * * Pascal work station graphic library initialization body * * Module = DGL_IBODY * Programer = BJS * Date = 8/27/82 * * Purpose : To set globals state to known value (uninitialized) * * Rev history * * Created - 6-27-83 - BJS *  Modified - * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * This module is called during module initialization ("pre-run") time. * It sets the state varibales for the graphics library to indicate that * the library is not initialized. This is done to indicated to the * library that pointers in global space may no longer be valid (i.e. * dynamic space used by the library no longer belongs to the library * after program termination). This procedure resets variables, which * might not be reset by the loading process since the library can be * 'P loaded'. * * When using segments, this module may be dummied out to allow graphics * routines to be called in many segments without re-initializing the * library in each segment. However, the library and the display * (graphics_init, display_init) MUST be initialized in the main * program. This is so the dynamic memory for the library will remain * between segment calls. * MNAME DGL_IBODY src module dgl_IBODY; src export src end; * Define entry points rorg 0 def dgl_ibody_dgl_ibody * Define externals refa dgl_vars lmode dgl_vars * Define ASMB control information nosyms * Define constants global equ a5 gle_gcb equ a3 * ** global variables * system_init equ dgl_vars-1 disp_init equ dgl_vars-2 loc_init equ dgl_vars-3 ****************************************************************************** * dgl_ibody_dgl_ibody equ * * Initialize system variables to not enabled. clr.  b system_init(global) clr.b disp_init(global) clr.b loc_init(global) rts end { } { Pascal work station graphics library } { } { Module = DGL_INQ } { Programer = BJS } { Date = 4/13/82 } { Modified 5/01/85 SFB - Added bobcat/gatorbox support } { Purpose: Holds all code for user inquires to the DGL system. } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in  paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $search 'TYPES', 'DGL_VARS', 'GEN', 'GLE_LIB'$ $include 'OPTIONS'$ $linenum 6000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module dgl_inq; import dgl_types; export procedure inq_ws ( opcode : integer; ssize : integer; isize : integer; rsize : integer; anyvar slist : gchar_list; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer); procedure inq_color_table ( index : integer; var parm1 : real; var parm2 : real; var parm3 : real); procedure inq_pgn_table ( index : integer; var pdensity : real; var porient : real; var pedge : integer); implement import dgl_vars, gle_ras_out, dgl_gen, GLE_HPHIL_ABSI {for dvr_rec}; procedure inq_color_table ( index : integer; var parm1 : real; var parm2 : real; var parm3 : real); { Purpose: To return information about a color table location } begin ck_system_init; ck_display_init; with gcb^,gle_gcb^ do {SFB NOV 84 - added gatorbox/bobcat} begin if color_table_size = 0 then error(err_no_ctable); if (index < 0) or (index > color_table_size) then error(err_bad_parms); if not realmap then with big_color_table_def(color_table_ptr^)[index] do if dgl_current_color_model = 1 { rgb } then begin parm1 := dglfloat(red); parm2 := dglfloat(green); parm3 := dglfloat(blue); end else { not rgb } convert_rgb_to_hsl(dglfloat(red),dglfloat(green),dglfloat(blue), parm1,parm2,parm3) else  { not gatorbox or bobcat } with color_table_ptr^[index] do if dgl_current_color_model = 1 { rgb } then begin parm1 := red; parm2 := green; parm3 := blue; end else { not rgb } convert_rgb_to_hsl(red,green,blue,parm1,parm2,parm3); end; { with gcb^, gle_gcb^ do } end; procedure inq_pgn_table ( index : integer; var pdensity : real; var porient : real; var pedge : integer); { Purpose: To return information about a polygon table location }  begin ck_system_init; ck_display_init; with gcb^ do begin if (index < 1) or (index > number_polygon_styles) then error(err_bad_parms); with poly_table_ptr^ [ index ] do begin pdensity := density; porient := orient; if edge then pedge := 1 else pedge := 0; end; end; end; procedure inq_ws ( opcode : integer; ssize : integer; isize : integer; rsize : integer; anyvar slist : gchar_list; anyvar ilist : gint_list; anyvar rlist : greal_  list; var ierr : integer); { Purpose: To return information some part of the DGL graphics system. } label 1; const numopcodes = 40; type opcode_type_def = (inq_250, inq_251, inq_252, inq_253, inq_254, inq_255, inq_256, inq_257, inq_258, inq_259, inq_450, inq_451, inq_1050, inq_1051, inq_1052, inq_1053, inq_1054, inq_1056, inq_1057, inq_1059, inq_1060, inq_1062, inq_1063, inq_1064, inq_1065, inq_1066, inq_1067, inq_1068, inq_1069, inq_1070, inq_1071, inq_1072, inq_1073, inq_1074, inq_1075, inq_1076, inq_11050, inq_11052, inq_12050, inq_13052 ); opcode_def = 0..32767; opcode_list_entry_def = packed record opcode : opcode_def; opcode_type : opcode_type_def; end; opcode_list_def = packed array [1..numopcodes] of opcode_list_entry_def; const opcode_list = opcode_list_def[ opcode_list_entry_def[opcode : 250, opcode_type : inq_250 ], opcode_list_entry_def[opcode : 251, opcode_type : inq_251 ], opcode_list_entry_def[opcode : 252, opcode_type : inq_252 ], opcode_list_entry_def[opcode : 253, opcode_type : inq_253 ], opcode_list_entry_def[opcode : 254, opcode_type : inq_254 ], opcode_list_entry_def[opcode : 255, opcode_type : inq_255 ], opcode_list_entry_def[opcode : 256, opcode_type : inq_256 ], opcode_list_entry_def[opcode : 257, opcode_type : inq_257 ], opcode_list_entry_def[opcode : 258, opcode_type : inq_258 ], opcode_list_entry_def[opcode : 259, opcode_type : inq_259 ], opcode_list_entry_def[opcode : 450, opcode_type : inq_450 ], opcode_list_entry_def[opcode : 451, opcode_type : inq_451 ], opcode_list_entry_def[opcode : 1050, opcode_type : inq_1050 ], opcode_list_entry_def[opcode : 1051, opcode_type : inq_1051 ], opcode_list_entry_def[opcode : 1052, opcode_type : inq_1052 ], opcode_list_entry_def[opcode : 1053, opcode_type : inq_1053 ], opcode_list_entry_def[opcode : 1054, opcode_type : inq_1054 ], opcode_list_entry_def[opcode : 1056, opcode_type : inq_1056 ], opcode_list_entry_def[opcode : 1057, opcode_type : inq_1057 ], opcode_list_entry_def[opcode : 1059, opcode_type : inq_1059 ], opcode_list_entry_def[opcode : 1060, opcode_type : inq_1060 ], opcode_list_entry_def[opcode : 1062, opcode_type : inq_1062 ], opcode_list_entry_def[opcode : 1063, opcode_type : inq_1063 ], opcode_list_entry_def[opcode : 1064, opcode_type : inq_1064 ], opcode_list_entry_def[opcode : 1065, opcode_type : inq_1065 ], opcode_list_entry_def[opcode : 1066, opcode_type : inq_1066 ], opcode_list_entry_def[opcode : 1067, opcode_type : inq_1067 ], opcode_list_entry_def[opcode : 1068, opcode_type : inq_1068 ], opcode_list_entry_def[opcode : 1069, opcode_type : inq_1069 ], opcode_list_entry_def[opcode : 1070, opcode_type : inq_1070 ], opcode_list_entry_def[opcode : 1071, opcode_type : inq_1071 ], opcode_list_entry_def[opcode : 1072, opcode_type : inq_1072 ], opcode_list_entry_def[opcode : 1073, opcode_type : inq_1073 ], opcode_list_entry_def[opcode : 1074, opcode_type : inq_1074 ], opcode_list_entry_def[opcode : 1075, opcode_type : inq_1075 ], opcode_list_entry_def[opcode : 1076, opcode_type : inq_1076 ], opcode_list_entry_def[opcode : 11050, opcode_type : inq_11050 ], opcode_list_entry_def[opcode : 11052, opcode_type : inq_11052 ], opcode_list_entry_def[opcode : 12050, opcode_type : inq_12050 ], opcode_list_entry_def[opcode : 13052, opcode_type : inq_13052 ]]; var index : gshortint; workstring : string[10]; strcnt : integer; begin ck_system_init; ierr := opcode_ck ( opcode,isize,rsize); { ck for good parms } { Find opcode in list } for index := 1 to numopcodes do if opcode_list[index].opcode = opcode then goto 1; ierr := 1  ; 1: if ierr = 0 then with gcb^,gle_gcb^ do case opcode_list[index].opcode_type of inq_250 : { return cell size (250) } begin rlist[1] := gcb^.dgl_char_width; rlist[2] := gcb^.dgl_char_height; end; inq_251 : { return marker cell size (251) } begin rlist[1] := marker_size_x * xdtow_scale; rlist[2] := marker_size_y * ydtow_scale; end; inq_252 : { return display resolution (252) } if disp_init then begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin rlist[1] := display_res_x; rlist[2] := display_res_y; end; end else begin rlist[1] := 0; rlist[2] := 0; end; inq_253 : { return max display dimensions (253) } if disp_init then with max_disp_lim do begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin rlist[1] := (xmax - xmin) / display_res_x; rlist[2] := (ymax - ymin) / display_res_y; end; end else begin rlist[1] := 0; rlist[2] := 0; end; inq_254 : { return aspect ratios (254) } begin rlist[1] := aspect_ratio; rlist[2] := log_aspect; end; inq_255 : { return locator resolution (255) } if loc_init then with gle_gcbi^ do begin rlist[1] := input_res_x; rlist[2] := input_res_y; end else begin rlist[1] := 0; rlist[2] := 0; end; inq_256 : { max locator dimensions (256) } if loc_init then with gle_gcbi^, max_loc_lim do begin rlist[1] := (xmax - xmin) / input_res_x; rlist[2] := (ymax - ymin) / input_res_y; end else begin rlist[1] := 0; rlist[2] := 0; end; inq_257 : { locator echo pos (257) } begin rlist[1] := w_loc_echo_x; rlist[2] := w_loc_echo_y; end; inq_258 : { current virtual limits (258) } with cur_vir_lim do begin rlist[1] := xlim; rlist[2] := ylim; end; inq_259 : { return cp (259) } begin if int_cp then begin rlist[1] := world_int_cpx; rlist[2] := world_int_cpy; end else begin rlist[1] := world_real_cpx; rlist[2] := world_real_cpy; end; end; inq_450: { return window limits (450) } with window_lim do begin rlist[1] := xmin; rlist[2] := xmax; rlist[3] := ymin; rlist[4] := ymax; end; inq_451: { return viewport limits (451) } with viewport_lim do begin rlist[1] := xmin; rlist[2] := xmax; rlist[3] := ymin; rlist[4] := ymax;  end; inq_1050: { Clipping supported at physical limits (1050) } begin if clipping_support then ilist [1] := 1 else ilist [1] := 0; end; inq_1051: { return display justification info (1051) } begin if disp_just = centered then ilist [1] := 0 else ilist [1] := 1; end; inq_1052: { return info about drawing in the background color (1052) } with gle_gcb^ do begin if disp_init then ilist [1] := background else ilist [1] := 0; end; inq_1053: { return color palette info (1053) } begin if disp_init then ilist[1] := pallette else ilist[1] := 0; end; inq_1054: { return color gamut info (1054) } begin if disp_init then ilist[1] := gamut else ilist[1] := 0; end; inq_1056: { return number linestyles (1056) } begin if disp_init then ilist[1] := number_dgl_linestyles else ilist[1] := 0; end; inq_1057: { return number linewidths (1057) } begin if disp_init then ilist[1] := linewidths else ilist[1] := 0; end; inq_1059: { return number markers (1059) } begin if disp_init then ilist[1] := number_markers else ilist[1] := 0; end; inq_1060: { return current color (1060) } begin ilist[1] := dgl_current_color; end; inq_1062: { return current linestyle (1062) } begin ilist[1] := dgl_current_linestyle; end; inq_1063: { return current li  newidth (1063) } begin ilist[1] := dgl_current_linewidth; end; inq_1064: { return current timming mode } begin ilist[1] := dgl_current_timming_mode; end; inq_1065: { return number polygon styles supported ( 1065) } begin if disp_init then ilist[1] := number_polygon_styles else ilist[1] := 0; end; inq_1066: { return current polygon color (1066) } begin ilist[1] := dgl_current_polygon_color; end; inq_1067: { return current polygon style (1067) } begin ilist[1] := dgl_current_polygon_style; end; inq_1068: { return maximum polygon vertices supported (1068) } begin if disp_init then ilist[1] := maximum_polygon_vertices else ilist[1] := 0; end; inq_1069: { retroactive polygon support (1069) } begin if disp_init and retroactive_polygon_support then ilist[1] := 1 else ilist[1] := 0; end; inq_1070: { device dependent polygons ( 1070 ) } begin if disp_init and (polygon_support = 1) then ilist [1] := 1 else ilist [1] := 0; end; inq_1071: { retroactive color support ( 1071 ) } begin if disp_init and retroactive_color_support then ilist [1] := 1 else ilist [1] := 0; end; inq_1072: { redef of background ( 1072 ) } begin if disp_init then ilist [1] := redef_background else ilist [1] := 0; end; inq_1073: { redef of color capability table ( 1073 ) } begin if disp_init and (color_table_size > 0) then ilist [1] := 1 else ilist [1] := 0; end; inq_1074: { return current color model ( 1074 ) } begin  ilist [1] := dgl_current_color_model; end; inq_1075: { return color capability table size ( 1075 ) } ilist [1] := color_table_size; inq_1076: { return current polygon linestyle ( 1076 ) } ilist [1] := dgl_current_polygon_linestyle; inq_11050: { return display device association (11050) } begin if not disp_init then begin if ssize >= 1 then begin slist[1] := '0'; ilist[1] := 1; end else ierr := 4; end else if disp_file_name <> '' then  begin for index := 1 to strlen(disp_file_name) do slist[index] := disp_file_name[index]; ilist [1] := strlen(disp_file_name); end else begin setstrlen(workstring,0); strwrite(workstring,1,strcnt,disp_dev_adr:0); strcnt := strcnt - 1; if ssize >= strcnt then begin for index := 1 to strcnt do slist[index] := workstring[index]; ilist[1] := strcnt; end else ierr := 4; end; end; inq_11052: { return locator device association (11052) } begin if not loc_init then begin if ssize >= 1 then begin slist[1] := '0'; ilist[1] := 1; end else ierr := 4; end else begin setstrlen(workstring,0); strwrite(workstring,1,strcnt,loc_dev_adr:0); strcnt := strcnt - 1; if ssize >= strcnt then begin for index := 1 to strcnt do slist[index] := workstring[index]; ilist[1] := strcnt; end else ierr := 4; end; end; inq_12050: { return display info (12050) } begin if not disp_init then begin if ssize >= 6 then begin for index := 1 to 6 do slist[index] := ' '; ilist[1] := 6; ilist[2] := 0; { disabled } end else ierr := 4; end else  begin if ssize >= display_name_char_count then begin for index := 1 to display_name_char_count do slist[index] := display_name[index]; ilist[1] := display_name_char_count; ilist[2] := 1; { enabled } end else ierr := 4; end; end; inq_13052: { return locator info (13052) } begin if not loc_init then begin if ssize >= 6 then begin for index := 1 to 6 do slist[index] := ' '; ilist[1] := 6; ilist[2] := 0; { dis  abled } ilist[3] := 0; end else ierr := 4; end else begin with gle_gcbi^ do if ssize >= input_name_char_count then begin for index := 1 to input_name_char_count do slist[index] := input_name[index];  ilist[1] := input_name_char_count; ilist[2] := 1; { enabled } $partial_eval on$ {for dvr_rec^ evaluation SFB} if (gle_gcbi^.input_handler_name = 'KNOB ') or ((loc_dev_adr = 202) and (dvr_rec^.extend <> 0)) then ilist[3] := 255 else if (loc_dev_adr = 201) or (loc_dev_adr = 202) then ilist[3] := 7 else ilist[3] := 1; $partial_eval off$ end else ierr := 4; end; end; end; { of case } end; end. { of module } { } { Pascal work station graphics library } { } { Module = DGL_POLY } { Programer = BJS } { Date = 11/10/82 } { Rev history:  } { Modified 6/01/85 SFB - Added big_color_table stuff for bobcat/gatorbox} { Purpose: Hold polygon user routines } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  } $modcal$ $include 'OPTIONS'$ $linenum 20000$ $ALLOW_PACKED ON$ {JWS 3/31/87} $search 'TYPES', 'DGL_VARS', 'GEN', 'GLE_LIB', 'LIB', 'DGL_RAS'$ { DGL_RAS added Nov 84 SFB } module DGL_POLY; import dgl_types; export procedure set_pgn_ls ( index : integer); procedure set_pgn_color ( index : integer); procedure set_pgn_table ( index : integer; pdensity : real; porient : real; pedge : integer); procedure set_pgn_style ( index : integer ); procedure int_polygon_dd ( num_points : integer; anyvar xvec, yvec : gshortint_list; anyvar opcodes : gshortint_list ); procedure polygon_dev_dep ( num_points : integer; anyvar xvec, yvec : greal_list; anyvar opcodes : gshortint_list ); procedure int_polygon ( num_points : integer; anyvar xvec,yvec : gshortint_list; anyvar opcodes : gshortint_list ); procedure polygon ( num_points : integer; anyvar xvec, yvec : greal_list; anyvar opcodes : gshortint_list ); implement import dgl_vars, dgl_gen, gle_types, gle_GEN, dgl_lib, asm, dgl_raster; {SFB Nov 84} const deg_to_rad = 0.01745329252; normalized_one = 32768; type vec_ptr_def = ^gint_list; work_ptr_def = ^gshortint_list; var saved_linestyle : integer; saved_linewidth : integer; stack_ptr : work_ptr_def; procedure set_polygon_color; { Purpose: To set the color polygons will be drawn with (send to gle) } var pass_rgb : boolean; h,s,l : real; begin with gcb^,gle_gcb^ do begin { If dither is to be used (b&w, moonunit, or 9836C with index > 15) then RGB values need to be passed. Otherwise the index is passed. } pass_rgb := (dither_s  upport = 1) and ( ((color_map_support = 1) and (dgl_current_polygon_color > gamut)) or ( color_map_support = 0)); if pass_rgb then begin info1 := 0; if gamut = 1 { black and white } then with color_table_ptr^[dgl_current_polygon_color] do begin if (display_name <> '98542A') and (display_name <> '98544A') and (display_name <> '98548A') then {SFB 2/2/88} { define only one parm for dither, use lit to set } { calc brite as defined from CIE diagram  } info2 := trunc((0.3*red+0.59*green+0.11*blue)*1023+0.5) else with big_color_table_ptr_def( color_table_ptr)^[dgl_current_polygon_color] do info2 := trunc(( 0.30*dglfloat(red ) +0.59*dglfloat(green) +0.11*dglfloat(blue ))*1023+0.5); info3 := 0; info4 := 0; gle_fill_index_color(gle_gcb); end { black and white } else { multi color device } begin if (display_name = '98700A') or (display_name = '98543A') or (display_name = '98545A') or (display_name = '98547A') or (display_name = '98549A') {SFB 2/2/88} or (display_name = '98550A') {SFB 2/2/88} or (display_name = 'E640 ') or (display_name = 'E1024 ') or (display_name = 'E1280 ') or (display_name = 'E640G ') or (display_name = 'E1280G') then {CFB 30JUL91} with big_color_table_ptr_def( color_table_ptr)^[dgl_current_polygon_color] do begin info2 := trunc(dglfloat(red)*1023+0.5); info3 := trunc(dglfloat(green)*1023+0.5); info4 := trunc(dglfloat(blue)*1023+0.5); end else with color_table_ptr^[dgl_current_polygon_color] do begin info2 := trunc(red*1023+0.5); info3 := trunc(green*1023+0.5); info4 := trunc(blue*1023+0.5); end; gle_fill_index_color(gle_gcb); end; { multi color device } end { if pass_rgb } else begin info1 := 1; info2 := dgl_current_polygon_color; gle_fill_index_color(gle_gcb); end; dgl_polygon_color_current := true; end; end; { set_polygon_color } procedure set_pgn_color (index : integer); { Purpose: To set the color polygons will be drawn with } var pass_rgb : boolean; h,s,l : real; begin ck_system_init; ck_display_init; with gcb^,gle_gcb^ do begin { Bad values of index are set to index 1 } if (index < 0) or ((index > gamut) and ((color_table_size = 0) or (index > color_table_size))) then index := 1; dgl_current_polygon_color := index; dgl_polygon_color_current := false; end; end; { set_pgn_color } procedure set_pgn_ls ( index : integer); { Purpose: To set the linestyle that polygons are drawn with } begin ck_system_init; ck_display_init; with gcb^ do begin if (index < 1) or (index > number_dgl_linestyles) then index := 1; dgl_current_polygon_linestyle := index; end; end; { set_pgn_line_style } procedure set_pgn_style ( index : integer ); { Purpose: To set the polygon style that polygons will be drawn with } begin ck_system_init; ck_display_init; with gcb^ do begin if (index < 1) or (index > number_polygon_styles) then index := 1; with poly_table_ptr^ [ index ] do begin { decode table and setup local vars } dgl_current_polygon_crosshatch := density < 0; dgl_current_polygon_density := density; dgl_current_polygon_angle := orient; dgl_current_polygon_edge := edge; dgl_current_polygon_style := index; end; end; end; procedure set_pgn_table ( index : integer; pdensity : real; porient : real; pedge : integer); { Purpose: To define an entry in the polygon table } begin ck_system_init; ck_display_init; with gcb^ do begin if ((index < 1) or (index > number_polygon_styles)) or ((pedge <> 0) and (pedge <> 1)) or ((pdensity < -1) or (pdensity > 1)) or ((porient < -90) or (porient > 90)) then error(err_bad_parms); with poly_table_ptr^ [ index ] do begin density := pdensity; ori  ent := porient; edge := pedge = 1; if index = dgl_current_polygon_style then set_pgn_style(dgl_current_polygon_style); end; end; end; procedure edge_polygon ( num_points : integer; anyvar vector : gint_list; anyvar opcodes : gshortint_list; polygon_simulation : boolean ); { Purpose : To draw edges around the specified polygon } var vector_count : integer; next_subpolygon : integer; i : integer; saved_color : integer; saved_linestyle : integer; saved_linewidth : integer; begin with gcb^, gle_gcb^ do begin if (polygon_simulation) and (dgl_current_polygon_density <> 0) then begin saved_color := dgl_current_color; saved_linestyle := dgl_current_linestyle; saved_linewidth := dgl_current_linewidth; set_color(dgl_current_polygon_color); set_line_style(dgl_current_polygon_linestyle); set_line_width(1); end; vector_count := 1; next_subpolygon := 1; for i := 1 to num_points do begin if vector_count = next_subpolygon then begin end_x := vector[vector_count+1]; end_y := vector[vector_count+2]; gle_move ( gle_gcb ); next_subpolygon := vector_count + vector[vector_count] * 2 + 1; vector_count := vector_count + 3; end else begin end_x := vector[vector_count]; end_y := vector[vector_count+1]; if opcodes[i] = 1 then gle_draw ( gle_gcb ) else gle_move ( gle_gcb ); vector_count := vector_count + 2; end; end; if (polygon_simulation) and (dgl_current_polygon_density <> 0) then begin set_color(saved_color); set_line_style(saved_linestyle); set_line_width(saved_linewidth); end; end; end; function int_div ( a, b : integer ) : integer; { Purpose : To perform an integer div with rounding } var temp : integer; begin temp := (2 * a ) div b; if odd ( temp ) then if temp > 0 then temp := temp + 1 else temp := temp - 1; int_div := temp div 2; end; procedure line_line_intersection ( p1x, p1y, p2x, p2y, p3x, p3y, p4x, p4y : integer; var ix, iy : integer ); { Purpose : To calculate the intersection of two lines } { Note: The two lines must intersect. } var num, denom, delta_x_21, delta_y_21, delta_x_31, delta_y_31, delta_x_43, delta_y_43 : integer; real_num, real_denom, real_factor : real; begin $range on$ delta_x_21 := p2x - p1x; delta_y_21 := p2y - p1y; delta_x_31 := p3x - p1x; delta_y_31 := p3y - p1y; delta_x_43 := p4x - p3x; delta_y_43 := p4y - p3y; try denom := delta_y_21 * delta_x_43 - delta_x_21 * delta_y_43; num := delta_x_21 * delta_y_31 - delta_y_21 * delta_x_31; {deleted SFB 9/16/86 and replaced as below ix := p3x + int_div((p4x-p3x)*num, denom); iy := p3y + int_div((p4y-p3y)*num, denom); } {to help correct uneven polygon crosshatch lines (not complete fix) SFB 9/16/86} real_factor := num/denom;  ix := round(p3x + (p4x-p3x)*real_factor); iy := round(p3y + (p4y-p3y)*real_factor); {end insertion SFB 9/16/86} $range off$ recover if escapecode = -4 { integer overflow } then begin real_denom := 1.0 * delta_y_21 * delta_x_43 - 1.0 * delta_x_21 * delta_y_43; real_num := 1.0 * delta_x_21 * delta_y_31 - 1.0 * delta_y_21 * delta_x_31; real_factor := real_num / real_denom; ix := trunc(p3x + (p4x-p3x) * real_factor + 0.5); iy := trunc(p3y + (p4y-p3y) * real_factor + 0.5); end else escape(escapecode); end; procedure draw_pg ( anyvar vector, work : gint_list; dgl_current_polygon_color, dgl_current_polygon_linestyle, normalized_sin,normalized_cos : integer; dgl_current_polygon_crosshatch : boolean; dgl_current_polygon_spacing : integer); { PURPOSE: To draw a polygon using the current polygon attributes } { The input format for vector is as follows (GLE polygon format): VECTOR [ Number of pts   in segment 1 ( 1st subpolygon ) ] [ X1 ] [ Y1 ] [ X2 ] [ Y2  ] [ : ] [ : ] [ Xn ] [ Yn ] [ Number of pts in segment 2 ( 2nd subpolygon ] [ X1 ] [ Y1 ] [ : ] [ :  ] [ Xm ] [ Ym ] : : [ 0 ] } { The basic algorithm is as follow: - Calculate dist between fill lines - Calculate fill line slope in terms of dx, dy - For every edge in the polygon, calculate the x intercept ( or y intercept for x major fill slope ) along a line parallel to the fill lines for each end point. With this information build a record with minimum intercept, maximum intercept, and both end points ordered by maximum intercept value. Maintain a minimum and maximum intercept value for all edge end points in the polygon. This information will be used to indicate where to start filling the polygon with fill lines. - Calculate using the minimum intercept value the first fill line that may intersect the polygon. - For each possible fill line do the following: - For each intercept record look for intersections. An intersection is determined by the current intercept value of the current fill line, falling between the minimum and maximum intercept values of the record. If an intersection is found, find the end point of the intersection and save the point. After all intersections for a given fill line are found, sort the end points. The sort alternates between top down, and bottom up for each fill line. This minimizes motion on mechanical devices.  Plot the end points alternating between moves and draws. } const normal_vertex = 0; short_vertex = 1; edge_vertex = 2; edge_index = 2; type point_def1 = array [0..1] of integer; point_def = array [0..2] of integer; point_array = array [1..maxint] of point_def1; intercept_rec_def = record intercept_p_min, intercept_p_max : integer; intercept_min_points : point_def; intercept_max_points : point_def; end; intercept_array = array [1..maxint] of intercept_rec_def; var intercept_list_ptr : ^intercept_array; p_list_ptr : ^point_array; p_count : integer; t, i, j : integer; intercept_count : integer; intercept_min : integer; intercept_max : integer; intercept_inc : integer; xmin, ymin : integer; dx, dy : integer; local_spacing : integer; vector_index : integer; num_vert : integer; last_index : integer; move_it : boolean; top_down_sort : boolean; x_major : boolean; hatch : boolean; saved_color : integer; vedge_index : integer; major_index : integer; first_index : integer; nxt_edge : integer; found_fill_line_on_edge : boolean; procedure calc_intercept ( pt_1_index : integer; pt_2_index : integer; switch_xy : boolean); { Purpose : For each end point of the edge defined by pt_1_index and pt_2_index, calculate the intercept of a line which runs though the end point and is parallel with the fill line. } var p1,p2,tp : integer; pt1x,pt1y : integer; pt2x,pt2y : integer; ix,iy : integer; tdx,tdy : integer; begin if switch_xy then begin ix := 1; iy := 0; tdx := dy; td y := dx; end else begin ix := 0; iy := 1; tdx := dx; tdy := dy; end; with intercept_list_ptr^[intercept_count] do begin pt1x := vector[pt_1_index+ix]; pt1y := vector[pt_1_index+iy]; pt2x := vector[pt_2_index+ix]; pt2y := vector[pt_2_index+iy]; p1 := pt1y - int_div(tdy * pt1x,tdx); { calc intercept } p2 := pt2y - int_div(tdy * pt2x,tdx); if p1 > p2 then begin { swap points } tp := p2; p2 := p1; p1 := tp; tp := pt2x; pt2x := pt1x; pt1x := tp; tp := pt2y; pt2y := pt1y; pt1y := tp; end; { save intercepts } intercept_count := intercept_count + 1; intercept_p_min := p1; intercept_p_max := p2; intercept_max := max(intercept_max,intercept_p_max); intercept_min := min(intercept_min,intercept_p_min); if p1 = p2 then begin intercept_min_points[edge_index] := edge_vertex; intercept_max_points[edge_index] := edge_vertex; if pt1x <= pt2x then begin intercept_min_points[ix] := pt1x; intercept_min_points[iy] := pt1y; intercept_max_points[ix] := pt2x; intercept_max_points[iy] := pt2y; end else begin intercept_max_points[ix] := pt1x; intercept_max_points[iy] := pt1y; intercept_min_points[ix] := pt2x; intercept_min_points[iy] := pt2y; end; end else begin intercept_min_points[edge_index] := normal_vertex; intercept_max_points[edge_index] := normal_vertex; intercept_min_points[ix] := pt1x; intercept_min_points[iy] := pt1y; intercept_max_points[ix] := pt2x; intercept_max_points[iy] := pt2y; end; end; end; procedure calc_vertex_info ( edge_a : integer; edge_b : integer); { Purpose : To mark points which should not be used when calc fill line } { end points. } var a_min, a_max, b_min, b_max : integer; begin with intercept_list_ptr^[edge_b] do begin b_min := intercept_p_min; b_max := intercept_p_max; end; with intercept_list_ptr^[edge_a] do begin a_min := intercept_p_min; a_max := intercept_p_max; if (intercept_max_points[edge_index] <> edge_vertex) then begin if a_min = b_max then intercept_min_points[edge_index] := short_vertex else if a_max = b_min then intercept_max_points[edge_index] := short_vertex; end; end; end; procedure sort( starting, ending, inc : integer ); { Purpose : To sort the P_LIST array. } var  sx : gle_shortint; sy : gle_shortint; index : gle_shortint; test_point : integer; temp_point : integer; done : boolean; begin if x_major then { sort by x } begin sx := 1; sy := 0; end else { sort by y } begin sx := 0; sy := 1; end; repeat index := starting + inc; done := true; test_point := p_list_ptr^[starting,sx]; while index <> ending + inc do begin temp_point := p_list_ptr^[index,sx]; if test_point > temp_point then begin p_list_ptr^[index,sx] := p_list_ptr^[index-inc,sx]; p_list_ptr^[index-inc,sx] := temp_point; temp_point := p_list_ptr^[index,sy]; p_list_ptr^[index,sy] := p_list_ptr^[index-inc,sy]; p_list_ptr^[index-inc,sy] := temp_point; done := false; end else test_point := temp_point; index := index + inc; end; until done end; { sort } begin { poly } with gcb^ do begin  intercept_list_ptr := addr(work); hatch := dgl_current_polygon_crosshatch; local_spacing := dgl_current_polygon_spacing; saved_color := dgl_current_color; if dgl_current_color <> dgl_current_polygon_color then set_color(dgl_current_polygon_color); with gle_gcb^ do repeat { cross hatching loop } hatch := not hatch; { Calc slope in terms of dx, dy } { Calc x or y spacing (intercept_inc) } x_major := true; major_inde x := 1; if abs(normalized_sin) = normalized_one { 90 deg } then begin dy := display_max_y; dx := 0; intercept_inc := local_spacing; end else if abs(normalized_sin) <= abs(normalized_cos) { <= 45 deg } then begin dx := display_max_x; dy := int_div(dx * normalized_sin,normalized_cos); x_major := false; major_index := 0; intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_cos)); end else begin  dy := display_max_y; dx := int_div(dy * normalized_cos,normalized_sin); intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_sin)); end; if intercept_inc < 1 then intercept_inc := 1; { Calc end point intercepts } intercept_count := 1; intercept_min := maxint; intercept_max := minint; vector_index := 1; while vector[vector_index] <> 0 do begin num_vert := vector[vector_index]; vector_index := vector_index + 1; for i := 2 to num_vert do calc_intercept ( vector_index+(i-1)*2,vector_index+(i-2)*2,x_major); last_index := vector_index+((num_vert-1)*2); calc_intercept ( vector_index,last_index,x_major); vector_index := last_index + 2; end; intercept_count := intercept_count - 1; vector_index := 1; vedge_index := 1; while vector[vector_index] <> 0 do begin num_vert := vector[vector_index]; first_index := vedge_index; last_index := vedge_index + num_vert; for i := 1 to num_vert do begin nxt_edge := vedge_index + 1; { The following while statement should read } { 'while (nxt_edge < last_index) and ...' } { however this "bug" was not found until after } { QA. It will not proceduce a user bug though } { since the following 'if' stmt with not use the } { bad results } while (nxt_edge < last_index) and (intercept_list_ptr^[nxt_edge]. intercept_max_points[edge_index] = edge_vertex) do  nxt_edge := nxt_edge + 1; if nxt_edge >= last_index then begin nxt_edge := first_index; while (nxt_edge < vedge_index) and (intercept_list_ptr^[nxt_edge]. intercept_max_points[edge_index] = edge_vertex) do nxt_edge := nxt_edge + 1; end; if (intercept_list_ptr^[nxt_edge]. intercept_max_points[edge_index] <> edge_vertex) then calc_vertex_info ( vedge_index,nxt_edge); vedge_index := vedge_index + 1; end; vector_index := vector_index + num_vert * 2 + 1; end; { Calc first fill line intercept value, adjust with lower left of display } p_list_ptr := addr(work,(intercept_count+1)*32); intercept_min := intercept_min - (intercept_min mod intercept_inc); xmin := 0; ymin := 0; top_down_sort := true; { Fill polygon } while intercept_min <= intercept_max do begin if x_major then xmin := intercept_min else ymin := intercept_min;  { Find intersections } p_count := 0; found_fill_line_on_edge := false; for i := 1 to intercept_count do begin with intercept_list_ptr^[i] do begin if (intercept_min = intercept_p_min) and (intercept_min = intercept_p_max) then found_fill_line_on_edge := true else if (intercept_min >= intercept_p_min) and (intercept_min <= intercept_p_max) then { intersection } begin if (intercept_min = intercept_p_min) then begin  if (intercept_min_points[edge_index] = normal_vertex) then begin p_count := p_count + 1; p_list_ptr^[p_count,0] := intercept_min_points[0]; p_list_ptr^[p_count,1] := intercept_min_points[1]; end; end else if (intercept_min = intercept_p_max) then begin if (intercept_max_points[edge_index] = normal_vertex) then begin p_count := p_count + 1; p_list_ptr^[p_count,0] := intercept_max_points[0]; p_list_ptr^[p_count,1]  := intercept_max_points[1]; end; end else begin p_count := p_count + 1; line_line_intersection(xmin,ymin,xmin+dx,ymin+dy, intercept_min_points[0],intercept_min_points[1], intercept_max_points[0],intercept_max_points[1], p_list_ptr^[p_count,0],p_list_ptr^[p_count,1]); end; end; end; end; if found_fill_line_on_edge then { add edge points } begin if p_count > 1 then sort(1,p_count,1); { sort bottom up } if odd(p_count) then p_count := p_count-1; { remove last move } for i := 1 to intercept_count do with intercept_list_ptr^[i] do begin if (intercept_min = intercept_p_min) and (intercept_min = intercept_p_max) then begin p_count := p_count + 1; p_list_ptr^[p_count,0] := intercept_min_points[0]; p_list_ptr^[p_count,1] := intercept_min_points[1]; p_count := p_count + 1; p_list_ptr^[p_count,0] := intercept_max_points[0]; p_list_ptr^[p_count,1] := intercept_max_points[1]; end; end; i := 1; repeat j := i + 2; while j < p_count do begin if (p_list_ptr^[i,major_index] <= p_list_ptr^[j+1,major_index]) and (p_list_ptr^[j,major_index] <= p_list_ptr^[i+1,major_index]) then begin if p_list_ptr^[i,major_index] > p_list_ptr^[j,major_index] then begin p_list_ptr^[i,0] := p_list_ptr^[j,0]; p_list_ptr^[i,1] := p_list_ptr^[j,1]; end; if p_list_ptr^[i+1,major_index] < p_list_ptr^[j+1,major_index] then begin p_list_ptr^[i+1,0] := p_list_ptr^[j+1,0]; p_list_ptr^[i+1,1] := p_list_ptr^[j+1,1]; end; for t := j to p_count-2 do begin p_list_ptr^[t,0] := p_list_ptr^[t+2,0]; p_list_ptr^[t,1] := p_list_ptr^[t+2,1]; end; p_count := p_count - 2; j := i + 2; end else j := j + 2; end; i := i + 2; until i > p_count; end; { Sort points } if p_count > 1 then begin top_down_sort := not top_down_sort; if top_down_sort then sort(p_count,1,-1) else sort(1,p_count,1); end; { draw a fill line } move_it := true; for i := 1 to p_count do begin end_x := p_list_ptr^[i,0]; end_y := p_list_ptr^[i,1]; if move_it then call ( move,gle_gcb ) else call ( draw,gle_gcb ); move_it := not move_it; end; intercept_min := intercept_min + intercept_inc; end; { of filling loop } if (not hatch) and dgl_current_polygon_crosshatch then begin t := normalized_sin; normalized_sin := -normalized_cos; normalized_cos := t; end; until hatch; { end of hatching loop } if saved_color <> dgl_current_polygon_color then set_color(saved_color); end; end; procedure draw_polygon ( anyvar vector, work : gint_list ); { PURPOSE: To draw a polygon using the current polygon attributes } { The input format for vector is as follows (GLE polygon format):  VECTOR [ Number of pts in segment 1 ( 1st subpolygon ) ] [ X1 ] [ Y1 ] [ X2 ] [ Y2 ] [ : ] [ : ] [ Xn ] [ Yn  ] [ Number of pts in segment 2 ( 2nd subpolygon ] [ X1 ] [ Y1 ] [ : ] [  : ] [ Xm ] [ Ym ] : : [ 0 ] } { normalized_one = 32768  } var local_angle : real; hatch : boolean; local_spacing : integer; rad_angle : real; sin_angle, cos_angle : integer { normalized fixed point numbers }; begin { draw_polygon } with gcb^ do begin if dgl_current_polygon_density <> 0 then begin local_angle := dgl_current_polygon_angle; hatch := dgl_current_polygon_crosshatch and (dgl_current_polygon_density <> 1); if dgl_current_polygon_density = 1 then local_spacing := gle_gcb^.polygon_solid_fill else local_spacing := abs(trunc(1/dgl_current_polygon_density * gle_gcb^.polygon_fill_factor)); if local_spacing < 1 then local_spacing := 1; if hatch then local_spacing := local_spacing * 2; if local_spacing = 1 then local_angle := 0; rad_angle := deg_to_rad * local_angle; sin_angle := trunc(sin(rad_angle) * normalized_one); cos_angle := trunc(cos(rad_angle) * normalized_one); draw_pg(vector,work,dgl_current_polygon_color,dgl_current_polygon_linestyle, sin_angle,cos_angle,hatch,local_spacing); end; end; end; procedure setup_for_polygon ( real_format : boolean; num_points : integer; anyvar xvec, yvec : gshortint_list; anyvar rxvec, ryvec : greal_list; anyvar opcodes  : gshortint_list; anyvar vector : vec_ptr_def; work_mult : integer; anyvar work_ptr : work_ptr_def; var last_subpoly : integer ); { Purpose : To prepare for drawing a polygon set. This includes } {  setting up attributes, creating work space, performing error } { checks, and creating a GLE format polygon. } var i : integer; sub_poly_start : integer; sub_poly_count : integer; point_count : integer; vector_count : integer; local_angle : real; rad_angle : real; begin ck_system_init; ck_display_init; $ovflcheck on$ if num_points <= 0 then error (err_neg_points); if opcodes[1] <> 2 then error (err_bad_parms); { allocate worst possible space for vector array } mark(stack_ptr); { mark current base } newbytes(vector,12*num_points+4); { alocate worst case space } with gcb^ do begin saved_linestyle := dgl_current_linestyle; saved_linewidth := dgl_current_linewidth; if dgl_current_linestyle <> dgl_current_polygon_linestyle then set_line_style ( dgl_current_polygon_linestyle ); if dgl_current_linewidth <> 1 then set_line_width(1); if not dgl_polygon_color_current then set_polygon_color; end; sub_poly_start := 1; i := 1; sub_poly_count := 1; point_count := 1; last_subpoly := 1; { last subpolygon in polygon } vector_count := 2; { first spot will hold count } while i <= num_points do begin if (opcodes[I]=2) and (i<>1) then begin vector^[sub_poly_start] := point_count-1; sub_poly_start := vector_count; { save space to hold count } vector_count := vector_count + 1; point_count := 1; sub_poly_count := sub_poly_count + 1; last_subpoly := i; end; point_count := point_count + 1; if real_format then convert_wtod(rxvec[i],ryvec[i],vector^[vector_count],vector^[vector_count+1]) else if short_flag then convert_intwtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1]) else convert_wtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1]); vector_count := vector_count + 2; i := i + 1; end; vector^[sub_poly_start] := point_count-1; vector^[vector_count] := 0; newbytes(work_ptr,work_mult*vector_count); { alocate work space for gle } with gcb^,gle_gcb^ do begin if dgl_current_polygon_crosshatch then info1 := 1 else info1 := 0; local_angle := dgl_current_polygon_angle; rad_angle := deg_to_rad * local_angle; info3 := trunc(sin(rad_angle) * normalized_one); info4 := trunc(cos(rad_angle) * normalized_one); if dgl_current_polygon_density = 1 then info2 := po lygon_solid_fill else if dgl_current_polygon_density = 0 then info2 := 0 else begin info2 := abs(trunc(1/dgl_current_polygon_density * polygon_fill_factor)); if info2 < 1 then info2 := 1; end; end; end; procedure finish_polygon; { Purpose: Restore linestyle and line width to current values } begin with gcb^ do begin if saved_linestyle <> dgl_current_polygon_linestyle then set_line_style(saved_linestyle); if saved_linewidth <> 1 then set_line_width(saved_linewidth); end; end; procedure int_polygon_dd ( num_points : integer; anyvar xvec, yvec : gshortint_list; anyvar opcodes : gshortint_list ); { Purpose : To output a device dependent polygon set } var t : array[1..1] of real; work_ptr : work_ptr_def; vector_ptr : vec_ptr_def; last_subpolygon : integer; use_simulation : boolean; begin try { must return 'new' space if escape occurs } setup_for_polygon ( false, num_points, xvec, yvec, t, t, opcodes, vector_ptr,14,work_ptr,last_subpolygon); with gle_gcb^ do begin use_simulation := true; if polygon_support = 1 then begin gle_get_polygon_info ( gle_gcb ); if error_return = 0 then begin info_ptr1 := vector_ptr;  info_ptr2 := work_ptr; gle_polygon ( gle_gcb ); use_simulation := false; end; end; end; finish_polygon; if gcb^.dgl_current_polygon_edge or (use_simulation) then edge_polygon ( num_points, vector_ptr^[1], opcodes,use_simulation); int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp } release(stack_ptr); { return all space } recover begin if escapecode <> -27 then release (stack_ptr); escape(escapecode); end; end; procedure polygon_dev_dep ( num_points : integer; anyvar xvec, yvec : greal_list; anyvar opcodes : gshortint_list ); { Purpose : To output a device dependent polygon set } var t : array[1..1] of real; work_ptr : work_ptr_def; vector_ptr : vec_ptr_def; last_subpolygon : integer; use_simulation : boolean; begin try { must return 'new' space if escape occurs } setup_for_polygon ( true, num_points, t, t, xvec, yvec, opcodes, vector_ptr,14,work_ptr,last_subpolygon); with gle_gcb^ do begin use_simulation := true; if polygon_support = 1 then begin gle_get_polygon_info ( gle_gcb ); if error_return = 0 then begin info_ptr1 := vector_ptr; info_ptr2 := work_ptr; gle_polygon ( gle_gcb ); use_simulation := false; end; end; end; finish_polygon; if gcb^.dgl_current_polygon_edge or (use_simulation) then edge_polygon ( num_points, vector_ptr^[1], opcodes, use_simulation); move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp } release(stack_ptr); { return all space } recover begin if escapecode <> -27 then release (stack_ptr); escape(escapecode); end; end; procedure int_polygon ( num_points : integer; anyvar xvec,yvec : gshortint_list; anyvar opcodes : gshortint_list ); { Purpose : To output a device independent polygon set } var t : array[1..1] of real; work_ptr : work_ptr_def; vector_ptr : vec_ptr_def; last_subpolygon : integer; begin try { must return 'new' space if escape occurs } setup_for_polygon ( false, num_points, xvec, yvec, t, t, opcodes, vector_ptr, 40, work_ptr,last_subpolygon ); draw_polygon ( vector_ptr^[1], work_ptr^[1] ); finish_polygon; if gcb^.dgl_current_polygon_edge then edge_polygon ( num_points, vector_ptr^[1], opcodes, false ); int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp } release(stack_ptr); { return all space } recover begin if escapecode <> -27 then release (stack_ptr); escape(escapecode); end; end; procedure polygon ( num_points : integer; anyvar xvec, yvec : greal_list; anyvar opcodes : gshortint_li st ); { Purpose : To output a device independent polygon set } var t : array[1..1] of real; work_ptr : work_ptr_def; vector_ptr : vec_ptr_def; last_subpolygon : integer; begin try { must return 'new' space if escape occurs } setup_for_polygon ( true, num_points, t, t, xvec, yvec, opcodes, vector_ptr,40, work_ptr,last_subpolygon ); draw_polygon ( vector_ptr^[1], work_ptr^[1] ); finish_polygon; if gcb^.dgl_current_polygon_edge then edge_polygon ( num_points, vector_ptr^[1], opcodes, false ); move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp } release(stack_ptr); { return all space } recover begin if escapecode <> -27 then release (stack_ptr); escape(escapecode); end; end; end. {module DGL_POLY} { } { DGL device dependent init routine } { } { Module = DGL_RASTER } { Programer = BJS } { Date = 1 - 5-83 } {  } { Purpose: To provide device dependent initialization for raster devices. } { Rev history } { Created - 1 - 5-83 BJS  } { Modified - 02-17-84 BDS Changed allocations from dynamic to global. } { Modified - 12- 84 SFB Added calls to dglfix/dglfloat } { Modified - 3 - 85 SFB Added opcodes for dumpgraphics } { Modified - 4 - 85 SFB Added calls to locator_esc } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS', 'GEN'$ $modcal$ $include 'OPTIONS.'$ { ******************** COMPILER OPTIONS ****************** } $linenum 17000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module DGL_RASTER; import dgl_types; export procedure dgl_raster_init ( control : integer ); implement import dgl_vars, sysdevs, asm, sysglobals, gle_types, gle_gen, gle_autl, gle_ras_out, dgl_gen; type init_color_table_def = ARRAY [0..15] of c_def; const init_color_table = init_color_table_def [ c_def [ red : 0, green : 0, blue : 0 ], { 0 } c_def [ red : 1, green : 1, blue : 1 ], { 1 } c_def [ red : 1, green : 0, blue : 0 ], { 2 } c_def [ red : 1, green : 1, blue : 0 ], { 3 } c_def [ red : 0, green : 1, blue : 0 ], { 4 } c_def [ red : 0, green : 1, blue : 1 ], { 5 } c_def [ red : 0, green : 0, blue : 1 ], { 6 } c_def [ red : 1, green : 0, blue : 1 ], { 7 } c_def [ red : 0, green : 0, blue : 0 ], { 8 } c_def[red:0.8 ,green:0.733333333333333,blue:0.2 ], { 9 } c_def[red:0.2 ,green:0.666666666666667,blue:0.466666666666667 ], { 10 } c_def[red:0.533333333333333,green:0.4 ,blue:0.666666666666667 ], { 11 } c_def[red:0.8 ,green:0.266666666666667,blue:0.4 ], { 12 } c_def[red:1.0  ,green:0.4 ,blue:0.2 ], { 13 } c_def[red:1.0 ,green:0.466666666666667,blue:0 ], { 14 } c_def[red:0.866666666666667,green:0.533333333333333,blue:0.266666666666667 ]];{ 15 } var step : integer; {SFB 3/11/85} {procedure hpm_new(var opject:anyptr; numbytes : integer); external;} procedure raster_linestyle ( index : integer); { Purpose: To set the linestyle that primitives are drawn with } type ls_map_def = packed array [1..13] of gbyte; const ls_map = ls_map_def [0,2,3,4,5,6,1,2,3,4,5,6,1]; begin with gle_gcb^ do begin info1 := ls_map[index]; { map DGL to GLE def } info2 := 1; { repeat rate 1% CHANGED FROM 4% IN 3.01 SFB 7/8/85 } info3 := 0; { linestyle mode } info4 := raster_patterns[index-1]; { pattern } gle_linestyle ( gle_gcb ); end; end; { set_line_style } function return_closest_color ( r,g,b : real; { target color } c_table_ptr : anyptr ) { system color map } : integer; var target_h, target_s, target_l : real; { HSL target color values } error_h, error_h2, { hue error distance squared } error_l, { lightness error distance squared } error_s, error_l2, error_s2 : real; { saturation error distance squared } map_h, map_l, map_s, { Current color map entry in HSL } error : real; { Distance from target to current color map entry } closest_error : real; i, closest_index : integer; { Best fit color map index } { Find closest color from system color map, to match target color. } { The closest color is the color which 'looks' the closest. This } { algorithm has been derived from a mixture of logic and } { experimentation. The algorithm calculates for each entry in the } { color map an error factor indicating how far off the color map } { value is from the target color. It then returns the color map } { index with the least error. } { Experimentation has showed that the best looking color is normaly } { the color with the least error in hue. However when the target } { color is near black or white this is not true, and when many color} { map entrys have a small hue error the closest hue does not produce} { the best color. The algorithm makes special cases out of the } { above cases and 'weights' the error result to reduce the effects } { of hue. } begin convert_rgb_to_hsl(r,g,b,target_h,target_s,target_l); closest_index := 1; closest_error := maxint;  { worst case error } for i := 0 to gle_gcb^.gamut do { for each CMAP entry } begin if not realmap then {SFB 11/84} with big_color_table_ptr_def(c_table_ptr)^[i] do { force anyptr to known type } convert_rgb_to_hsl(dglfloat(red),dglfloat(green),dglfloat(blue), map_h,map_s,map_l) else with color_table_ptr_def(c_table_ptr)^[i] do { force anyptr to known type } convert_rgb_to_hsl(red,green,blue,map_h,map_s,map_l); { Calc errors, note that since Hue is circular it must } { be calc as shortest dist of either direction } error_h := abs(map_h-target_h); error_h2 := abs(map_h-1-target_h); if error_h2 <= error_h then error_h := error_h2; error_h2 := error_h * error_h; error_s := abs(map_s-target_s); error_l := abs(map_l-target_l); error_s2 := error_s * error_s; error_l2 := error_l * error_l; if target_l < 0.1 then { special case where request is near black } begin { With small lum in cmap, sat and hue are undifined and can't } { be used in error calculation } if map_l < 0.01 then error := error_l else { With small sat in cmap, hue is undifined and can't be used } { in error calculation   } if map_s < 0.01 then error := error_l + error_s2 else error := error_l + error_h2 + error_s2; end else if target_s < 0.1 then { special casewhere request is near white } begin { With small lum in cmap, sat and hue are undifined and can't } { be used in error calculation } if map_l < 0.01 then error := 3 else { With small sat in cmap, hue is undifined and can't be used } { in error calculation  } if map_s < 0.01 then error := error_l2 + error_s else error := error_l2 + error_h2 + error_s; end else { normal case } { With small lum in cmap, sat and hue are undifined and can't } { be used in error calculation } if map_l < 0.01 then error := 3 else { With small sat in cmap, hue is undifined and can't be used } { in error calculation } if map_s < 0.01 then error := 3 else error := error_h2; if error < closest_error then begin closest_error := error; closest_index := i; end; end; return_closest_color := closest_index; end; procedure raster_color ( index : integer ); var intensity : real; h,s,l : real; begin with gcb^,gle_gcb^ do begin if gamut = 1 then { b&w } begin { Numbers from Dawn (HP-9000) DGL for 2648 terminal } if realmap then {MODS SFB 11/84} with color_table_ptr^[index] do intensity := 0.3*red + 0.59*green + 0.11*blue else with big_color_table_def(color_table_ptr^)[index] do intensity := 0.30*dglfloat(red) + 0.59*dglfloat(green) + 0.11*dglfloat(blue); if intensity < 0.06 then info1 := 0 else info1 := 1; end else if raster_device_rec_ptr(dev_dep_stuff)^.devicetype = 2 then { moonunit } with color_table_ptr^[index] do info1 := return_closest_color(red,green,blue,addr(init_color_table)) else { 9836C } if (index <= gamut) then info1 := index else if realmap then with color_table_ptr^[index] do info1 := return_closest_color(red,green,blue,color_table_ptr) else with big_color_table_def(color_table_ptr^)[index] do info1 := return_closest_color(dglfloat(red),dglfloat(green), dglfloat(blue),color_table_ptr); gle_index_color ( gle_gcb ); { this function sets color } end; end; procedure raster_color_table ( index : integer; parm1 : real; parm2 : real; parm3 : real); var color_list : array [1..3] of gle_shortint; intensity : real; begin with gcb^,gle_gcb^ do begin if dgl_current_color_model = 2 then convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3); if (index <= gamut) and (color_map_support = 1) then begin info1 := index; info2 := index; color_list[1] := trunc(parm1 * 1023 + 0.5); color_list[2] := trunc(parm2 * 1023 + 0.5); color_list[3] := trunc(parm3 * 1023 + 0.5); info_ptr1 := addr(color_list); gle_define_color_map ( gle_gcb ); end; if realmap then with color_table_ptr^[index] do {MODS SFB 11/84} begin red := parm1; green := parm2; blue := parm3; end else with big_color_table_def(color_table_ptr^)[index] do begin red := dglfix(parm1); green := dglfix(parm2); blue := dglfix(parm3); end; if index = 0 then if color_map_support = 1 then dgl_background_index := 0 else if gamut = 1 then { b&w } begin { Numbers from Dawn (HP-9000) DGL for 2648 terminal } intensity := 0.3*parm1 + 0.59*parm2 + 0.11*parm3; if intensity < 0.06 then dgl_background_index := 0 else dgl_background_index := 1; end else { moonunit } dgl_background_index := return_closest_color(parm1,parm2,parm3,addr(init_color_table)) end; end; procedure set_all_color_table ( anyvar list : greal_list ); {MODS SFB 11/84} var color_lis t : array[0..767] of gle_shortint; parm1, parm2, parm3 : real; i, adr : gshortint; begin with gcb^,gle_gcb^ do begin for i := 0 to color_table_size - 16 do begin adr := (i*3)+1; {3.0 BUG SFB 4/29/85:GREAL_LIST INDEXED FROM 1 NOT 0} parm1 := list[adr]; parm2 := list[adr+1]; parm3 := list[adr+2]; if dgl_current_color_model = 2 then convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3); color_list[adr] := trunc(parm1 * 1023 + 0.5); color_list[adr+1] := trunc(parm2 * 1023 + 0.5); color_list[adr+2] := trunc(parm3 * 1023 + 0.5); begin {SFB 11/84} if realmap then with color_table_def(color_table_ptr^)[i] do begin red := parm1; green := parm2; blue := parm3;  end else with big_color_table_def(color_table_ptr^)[i] do begin red := dglfix(parm1); green := dglfix(parm2); blue := dglfix(parm3); end; end; end; info1 := 0; info2 := color_table_size - 16 {15}; info_ptr1 := addr(color_list); gle_define_color_map ( gle_gcb ); end; end; procedure dummy_on_off ( gcb : graphics_control_block_ptr ); begin end; {CHANGED TO DOGRAPHICS_ON_OFF SFB--6/6/85-SEE DGL_INIT_RASTER BELOW} procedure dographics_on_off ( gcb : graphics_control_block_ptr ); var on : boolean; begin with gcb^ do begin on := info1 <> 0; if ( on and not graphicstate ) or ( not on and graphicstate ) then call (togglegraphicshook); end; end; procedure dump_graphics ( mask : integer ); { Purpose: To dump bit/pixel bit map to standard printer } label 1; const gbuffersize = 255; var gbuffer : packed array [1..gbuffersize] of char; y : integer; bytes_wide : integer; begin gbuffer[1] := chr(27); { escape sequence for graphics } gbuffer[2] := '*'; gbuffer[3] := 'b'; gbuffer[4] := '6'; gbuffer[5] := '4'; gbuffer[6] := 'W'; with gle_gcb^ do begin bytes_wide := (display_max_x - display_min_x + 8) div 8; info_ptr1 := addr(gbuffer[7]); info1 := mask; for y := display_min_y to display_max_y do begin info2 := y; gle_get_raster ( gle_gcb ); write(gfiles[4]^,gbuffer:bytes_wide+6); if ioresult <> ord(inoerror) then goto 1; end; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure raster_input_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); { Purpose : To perform an input escape function } begin ierr := 1; { no input escape display functions supported } call(gcb^.proc_locator_input_esc, opcode, isize, rsize, {SFB 4/11/85} ilist, rlist, ierr); {give locator a chance at the opcode} end; { input_esc } {DUMPBITMAP SFB 3/85} procedure dumpbitmap; {the global "step" controls whether we print only every second pixel (step =2), or every pixel (step =1). step is only active if the display has halfwide pixels (at present, lores_bobcat)} label 1; type gbyte = 0..255; row_def = packed array [0..maxint] of char; aptrtype = ^anyptr; var row : ^row_def; gbuffer : packed array [1..263] of char; i,j, h,w,fbw, {added 3/18/88 SFB} pos, index, bit_mask, result, romptr, headerlen, planes : integer; halfwide : boolean; wstr : string[10]; function value : shortint; type chptr = ^char; var temp : shortint; begin temp := ord(chptr(romptr)^) * 256; value := temp + ord(chptr(romptr+2)^); end; begin with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin row := aptrtype(plane1_addr)^; planes := gamut + 1; if devicetype = 4 then {gator} begin fbw := 1024; w := 1024; h := 768; step := 1; {force "square pixels" for gator} end else begin {standard ID ROM available} romptr := control_space + hex('5'); fbw := value; {amount to step to get to next scanline.  SFB} romptr := control_space + hex('d'); w := value; {display area width--pixels, from ID ROM} romptr := control_space + hex('11'); h := value; {display area height--pixels, from ID ROM} romptr := control_space + hex('15'); halfwide := odd(value); if not halfwide then {see if lsb of ROM location $17 is 1} step := 1 {force square pixels on hires bobcat} else if step = 2 then {half wide pixels on lores bobcat} begin {fix for STARS 1650076745/1650076802} w := w div 2; fbw := fbw div 2; {98542/3 OPDCODE 54 dump was garbaged} end; {SFB 2/03/89} end; end; {with} write(gfiles[4]^,#27'*rA');  {graphics initiation} if ioresult <> 0 then goto 1; gbuffer[1] := chr(27); {start creating header} gbuffer[2] := '*'; gbuffer[3] := 'b'; wstr := ''; {put number of chars into header} strwrite(wstr, 1, i, w div 8:1); headerlen := 4 + strlen(wstr); for i:=1 to strlen(wstr) do gbuffer[i+3] := wstr[i]; gbuffer[headerlen] := 'W'; {Note that if ever we mix halfwide with a frame buffer whose fbw is not equal the display width (w), this algorithm will need to be replaced. SFB} for j:=0 to h-1 do begin for i:=0 to (w div 8)-1 do begin result := 0; {index := j*w + i*8;} index := j*fbw + i*8; bit_mask := 256; for index := index to index + 7 do begin bit_mask := bit_mask div 2; if ord(row^[index*step]) mod planes <> 0 then result := bit_mask + result; end; gbuffer[i+headerlen+1] := chr(result); end; write(gfiles[4]^, gbuffer:(w div 8)+headerlen); if ioresult <> 0 then goto 1; if (halfwide) and (step = 1) then {lores with all pixels dumped} write(gfiles[4]^, gbuffer:(w div 8)+headerlen); if ioresult <> 0 then goto 1; end; write(gfiles[4]^, #27'*rB'); {graphics termination} 1: end; {dumpbitmap} procedure raster_output_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); { Purpose : To perform an output escape funtion  } var on : boolean; begin with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do if (opcode = 52) and (devicetype < 4 ) and (devicetype <> 2) then begin if ierr = 0 then call (dumpgraphicshook); end else if (opcode = 52) and (devicetype = 2) then begin if ierr = 0 then dump_graphics(-1); end else if (opcode = 52) and (devicetype >= 4) then {added for gator etc case} begin if ierr = 0 then {SFB 3/11/85} begin step := 1; dumpbitmap; end; end else if (opcode = 54) and (devicetype >= 4) then {SFB 3/11/85} begin if ierr = 0 then begin step := 1 + ord(devicetype = 7); dumpbitmap; end end else if (opcode = 53) and (devicetype = 3) then begin if ierr = 0 then gle_await_blanking ( gle_gcb ); end else if (opcode = 250) {{ and ((devicetype = 0) or (devicetype = 2)) {} then begin { marmot and aspen and moonunit} if ierr = 0 then begin if (rlist[1] > 0.0) and ( rlist[2] > 0.0 ) then begin display_res_x := rlist[1]; display_res_y := rlist[2]; end else ierr := 4; end; end else if (opcode = 1050) and (devicetype < 4) then { graphics on / off } begin if ierr = 0 then begin info1 := ilist[1]; gle_graphics_on_off ( gle_gcb ); end; end else if (opcode = 1051) and (devicetype <> 2) and (devicetype < 4) {BUGFIX SFB 3/11/85} then { alpha on / off } begin if ierr = 0 then begin on := ilist[1] <> 0; if ( on and not alphastate ) or ( not on and alphastate ) then call(togglealphahook); end; end else if (opcode = 1052) then begin   if ierr = 0 then begin info1 := ilist[1]; if (info1 < 0) or (info1 > 3) then info1 := 0; if info1 = 1 then info1 := 2 else if info1 = 2 then info1 := 1; gle_define_drawing_mode ( gle_gcb ); end; end else if (opcode = 1053) and ((devicetype = 3) or (devicetype = 2)) then begin if ierr = 0 then dump_graphics(ilist[1]); end else if (opcode = 1053) and (devicetype = 4) then {for GATOR} begin if ierr = 0 then begin step := 1;  dumpbitmap; end; end else if (opcode = 1054) and (devicetype <> 4) then begin if ierr = 0 then begin info1 := ilist[1]; info2 := 0; gle_clear(gle_gcb); end; end else if (opcode = 10050) and ((devicetype = 3) or ((devicetype > 4) and (gamut >1))) then begin if (ierr = 3) and (rsize = 3*(gamut+1)) { opcode_ck gave real size err } then begin ierr := 0; set_all_color_table(rlist); end; end else {MODS SFB 4/11/85} ierr := 1; {locator_output_esc clears this if it processes opcode} call(gcb^.proc_locator_output_esc, opcode, isize, rsize, ilist, rlist, ierr); {give locator a chance at the opcode} end; { raster_output_esc } procedure dgl_raster_init ( control : integer ); {MODS SFB 12/84} type default_poly_table_def = array[1..16] of poly_entry_def; control_def = packed record case gshortint of 0 : (whole : gshortint); 1 : (part : packed record b15,b14,b13,b12, b11,b10,b9, b8, clr_inhibit,b6,b5,b4, b3,b2,b1,b0 : boolean; end); end; const default_poly_table = default_poly_table_def [ poly_entry_def [ density : 0.0 , orient : 0.0, edge : true ], { 1 } poly_entry_def [ density : 0.125, orient : 90.0, edge : true ], { 2 } poly_entry_def [ density : 0.125, orient : 0.0, edge : true ], { 3 } poly_entry_def [ density : -0.125, orient : 0.0, edge : true ], { 4 } poly_entry_def [ density : 0.125, orient : 45.0, edge : true ], { 5 } poly_entry_def [ density : 0.125, orient : -45.0, edge : true ], { 6 } poly_entry_def [ density : -0.125, orient : 45.0, edge : true ], { 7 } poly_entry_def [ density : 0.25 , orient : 90.0, edge : true ], { 8 } poly_entry_def [ density : 0.25 , orient : 0.0, edge : true ], { 9 } poly_entry_def [ density : -0.25 , orient : 0.0, edge : true ], { 10 } poly_entry_def [ density : 0.25 , orient : 45.0, edge : true ], { 11 } poly_entry_def [ density : 0.25 , orient : -45.0, edge : true ], { 12 } poly_entry_def [ density : -0.25 , orient : 45.0, edge : true ], { 13 } poly_entry_def [ density : -0.5 , orient : 0.0, edge : true ], { 14 } poly_entry_def [ density : 1.0 , orient :  0.0, edge : false], { 15 } poly_entry_def [ density : 1.0 , orient : 0.0, edge : true ]];{ 16 } var temp_control : control_def; i : integer; temp_color_model : integer; c : real; begin with gle_gcb^ do if (display_name = '9837a ') or (display_name = '98700A') {SFB 6/11/85} or (display_name = '98542A') or (display_name = '98543A') or (display_name = '98544A') or (display_name = '98545A') or (display_name = '98547A') or (display_name = '98548A') {SFB 2/2/88} or (display_name = '98549A') or (display_name = '98550A') {SFB 2/2/88} or (display_name = 'E640 ') or (display_name = 'E1024 ') {CFB 30JUL91} or (display_name = 'E1280 ') or (display_name = 'E640G ')  {CFB 30JUL91} or (display_name = 'E1280G') then {CFB 30JUL91} gle_gcb^.graphics_on_off := dummy_on_off else if gle_gcb^.display_name <> '98627A' then gle_gcb^.graphics_on_off := dographics_on_off; {SFB--6/6/85} with gle_gcb^,gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin disp_just := centered; clipping_support := true; retroactive_polygon_support := false; retroactive_color_support := color_map_support = 1; number _markers := 19; number_dgl_linestyles := 8; maximum_polygon_vertices := 32767; proc_output_esc := raster_output_esc; proc_input_esc := raster_input_esc; proc_linestyle := raster_linestyle; proc_color := raster_color; proc_color_table := raster_color_table; temp_control.whole := control; if not temp_control.part.clr_inhibit then with gle_gcb^ do begin info1 := -1; { clear all planes } info2 := 0; gle_clear ( gle_gcb ); end; { allocate color table space } temp_color_model := dgl_current_color_model; dgl_current_color_model := 1; { rgb } if gamut>=15 then color_table_size := gamut + 16 else color_table_size := 31; color_table_ptr := addr(color_table_def_space); if (gamut > 1) then begin for i := 0 to 15 do with init_color_table[i] do raster_color_table(i,red,green,blue); raster_color_table(16,1,1,1); end else begin raster_color_table(0,0,0,0); for i := 1 to 16 do begin c := ((17-i) / 16); raster_color_table(i,c,c,c); end; end; for i := 17 to color_table_size {to 31} do raster_color_table(i,1,1,1); dgl_current_color_model := temp_color_model; gle_gcb^.info1 := 1; gle_index_color( gle_gcb); { allocate polygon table space } number_polygon_styles := poly_table_size; poly_table_ptr := addr(poly_table_def_space); for i := 1 to poly_table_size do poly_table_ptr^[i] := default_poly_table[i]; display_echo_mult := 1; end; end; end. { dgl_raster } { } { Graphics Low End } { } { Module = DGL_TOOLS } { Programer = BJS } { Date = 12-07-82 } {  } { Purpose: To provide general tools for GLE and DGL. } { Rev history } { Created - 12-07-82  } { Modified - 9-07-83 BJS Changed to add check for marbox } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $include 'OPTIONS'$ { ********************* Compiler options *************** } $linenum 20000$ $search 'GLE_LIB'$ module DGL_TOOLS; export function return_machine_type : integer; implement import gle_types; {Look for internal bitmap display present - SFB 7/11/85} function bitmapcrttype : boolean; const gatorid =25; bitmapid =57; type shortint = -32768..32767; var dummy : shortint; ptr : ^shortint; begin ptr:=anyptr(hex('560000')); bitmapcrttype := false; try dummy:=ptr^; dummy := dummy mod 128; if (dummy = gatorid) OR (dummy = bitmapid) then bitmapcrttype := true else bitmapcrttype := false; recover ; end; function return_machine_type : integer; type sysflag_def = packed record {bit7 SFB 6/20/85} bitmap,bit6,hpib,crt_config, kbd,high,big_graph,alpha5 0 : boolean; end; crt_reg_def = packed record selfinit,bit14,bit13,top1,top2,highlite, graph,alpha, bit7,bit6,bit5,bit4,bit3,bit2,bit1,bit0 : boolean; end; var sysflag [ hex('fffffed2') ] : sysflag_def; crt_reg [ hex('0051fffe') ] : crt_reg_def; temp_machine_type : integer; begin if sysflag.big_graph then begin { could be 9836A or 9836C or Marbox } if sysflag.crt_config then { might be 9836C or Marbox } begin { CRT reg bits 12 (top1) and 11 (top2) are defined } { as follows: } { 00 - Monochrome } { 01 - 4 planes starting at $520000 } { 1 pixel / byte; 4 bits / pixel } { 10 - 3 planes starting at $528000 } { 8 pixel / byte (moonunit like) } { 11 - 8 planes starting at $520000 } { 1 pixel / byte; 8 bits / pixel } with crt_reg do if (not top1) and (top2) then  temp_machine_type := m9836c { 9836C } else if (not top1) and (not top2) then temp_machine_type := m9836a { Marbox } else temp_machine_type := munknown; { bitmap or unknown - 11/84 - SFB } end else  begin temp_machine_type := m9836a; { 9836A } end; end else if sysflag.alpha50 then begin temp_machine_type := m9826a; { 9826A } end else begin temp_machine_type := m9816a; { 9816A }  end; if temp_machine_type = munknown then {SFB 7/11/85} if bitmapcrttype then temp_machine_type := m9826a; return_machine_type := temp_machine_type; end; end. { } { Pascal work station graphics library } { } { Module = DGL_VARS } { Programer = BJS } { Date = 2/1/82 } {  } { Purpose: To hold graphics library global variables } { Rev history } { 5-13-82 BJS - Made changes to add hp9816 support  } { 5-24-82 BJS - Made changes to support inq of world cp values } { 7-01-82 BJS - Made changes to support 8 color HP 9836C } { 8-25-82 BJS - Major mods for addition of GLE } { 2-17-84 BDS - Changed gcb vars to global for Pascal 3.0 } { 4-08-85 SFB - Added proc_locator_xxx for HPHIL tablet support } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal,TABLES$ $search 'TYPES', 'GLE_LIB'$ $include 'OPTIONS'$ module DGL_VARS; import DGL_TYPES,GLE_TYPES; export $linenum 1000$ const graphics_rev = '3.25'; { revision number } default_color_table_size = 32; default_poly_table_size = 16; poly_table_size = 16; type bounds = record xmin : real; xmax : real; ymin : real; ymax : real; end; vir_bounds = record xlim : real; ylim : real; end; type c_def = packed record red : real; green : real; blue   : real; { 24 bytes each } end; int_c_def = packed record red : gshortint; green : gshortint; blue : gshortint; end; color_table_def = array [0..31] of c_def; color_table_ptr_def = ^color_table_def; big_color_table_def = array [0..271] of int_c_def; big_color_table_ptr_def = ^big_color_table_def; poly_entry_def = packed record density : real; orient : real; edge : boolean; { 18 bytes each } end; poly_table_def = array [1..poly_table_size] of poly_entry_def; poly_table_ptr_def = ^poly_table_def; { a large number of system variables are alocated in dynamic memory to conserve the amount of global space used. These variables are all part of the GCB (graphics control block)  } graphics_control_block1 = record aspect_ratio : real; { current aspect ratio } log_aspect : real; { aspect ratio of the logical display limits } log_disp_lim : bounds; { logical display limits } max_disp_lim : bounds; { maximum display limits } def_disp_lim : bounds; { default display limits } log_loc_lim : bounds; { logical locator limits } max_loc_lim : bounds; { maximum locator limits } def_loc_lim : bounds; { default locator limits } window_lim : bounds; { current window } viewport_lim : bounds; { current viewport } cur_disp_lim : bounds; { current display coordinate limits } cur_vir_lim : vir_bounds; { current virtual limits } dgl_char_width : real; { current character width (world) } dgl_char_height : real; { current character height (world) } char_rot_h : real; { char rot cos vector } char_rot_w : real; { char rot sin vector } disp_just : (centered,lowerleft); { display justification } dxunits : real; { # of units in the logical display coord. } dyunits : real; { system. } number_dgl_linestyles : gshortint; number_markers : gshortint; number_polygon_styles : gshortint; color_table_size : gshortint; dgl_current_color : gshortint; dgl_current_linestyle : gshortint; dgl_current_linewidth : gshortint; dgl_current_timming_mode : gshortint; dgl_current_polygon_color : gshortint; dgl_current_polygon_style : gshortint; dgl_current_polygon_linestyle : gshortint; dgl_current_polygon_angle : real; dgl_current_polygon_density : real; dgl_current_polygon_edge : boolean; dgl_current_polygon_crosshatch : boolean; dgl_current_color_model : gshortint; maximum_polygon_vertices : gshortint; retroactive_polygon_support : boolean; retroactive_color_support : boolean; clipping_support : boolean; disp_dev_adr : integer; { display device address } disp_file_name : gstring255; { name of device file, knull if device address is used } loc_dev_adr : integer; { locator device address } disp_eq_loc : boolean; { true if loc and disp are same device } poly_table_ptr : poly_table_ptr_def; color_table_ptr : color_table_ptr_def; marker_size_x : integer; { marker size in device units } marker_size_y : integer; proc_output_esc : procedure ( opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var error : integer); proc_input_esc : procedure ( opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var error : integer); proc_linestyle : procedure ( index : integer ); proc_color : procedure ( index : integer ); proc_color_table : procedure ( inde x : integer ; p1,p2,p3 : real ); dgl_background_index : integer; proc_await_locator : procedure ( var echo : integer; var button : integer; var x,y : real ); proc_sample_locator : procedure ( echo : integer; var x,y : real ); dgl_polygon_color_current : boolean; { true if polygon color set in gle } {ADDED 4/8/85 SFB FOR HPHIL SUPPORT} proc_locator_output_esc : procedure ( opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var error : integer); proc_locator_input_esc : procedure ( opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var error : integer); end; const eight_diget_epsilon = 0.00000001; { a number which will change the value of a 8 diget number when added to it } { Initialization constants follow } init_color = 1;  init_linestyle = 1; init_linewidth = 1; init_char_width = 0.07; init_char_height = 0.1; init_char_width_factor = 0.035; init_char_height_factor = 0.05; init_char_rot_w = 1.0; init_char_rot_h = 0.0; init_timming_mode = 0; { This is diff from HP 9000 due to PWS 1.0 compatiblity } init_cpx = 0; init_cpy = 0; init_dev_adr = 0; init_window = bounds [ xmin : -1.0, xmax : 1.0, ymin : -1.0, ymax : 1.0]; init_viewport = bounds [ xmin : 0.0,  xmax : 1.0, ymin : 0.0, ymax : 1.0]; init_aspect = 1.0; init_vir_lim = vir_bounds [ xlim : 1.0, ylim : 1.0]; init_display_lim = bounds [ xmin : 0.0, xmax : 8000000.0, ymin : 0.0, ymax : 8000000.0]; init_locator_lim = bounds [ xmin : 0.0, xmax : 8000000.0, ymin : 0.0, ymax : 8000000.0]; { definitions of some standard colors (used only on raster displays) } { that are used in locator echoing  } dominate_mode = 0; non_dominate_mode = 1; erase_mode = 2; complement_mode = 3; solid_linestyle = 1; io_error_number = -26; graphics_error_number = -27; { definitions of some std device adrs  } internal_display = 3; internal_locator = 2; { definitions of some defauts used for raster linestyle generation } initial_pattern = -1; { The following const are for user errors  } err_sys_int = 1; { system not initialized } err_dis_int = 2; { display not initialized } err_loc_int = 3; { locator not initialized } err_echo_dis_int = 4; { echo needs display initialized } err_aspect = 6; { illegal aspect ratio } err_bad_parms = 7; { illegal parameters } err_out_phys = 8; { parms outside physical disp lim } err_out_wind = 9; { parms outside window lim } err_disp_eq_loc = 10; { loc lim given when disp and loc are the same } err_out_virt = 11; { parms outside virt lim } err_no_display_hardware = 12; { missing display hardware } err_out_loc = 13; { parms outside loc lim } err_no_ctable = 14; { device does not support color table } err_neg_points = 18; { polygon npts < 0 } var { define system initialization variables } system_init : boolean; { is the system init } disp_init : boolean; { is the display init } loc_init : boolean; { is the locator init } graphics_error : integer; { holds last error number } gcb : ^graphics_control_block1; { pointer to the dynamic vars } { define holders of the current position  } cpy : integer; cpx : integer; world_int_cpx : gshortint; { last int_move / int_line cp value } world_int_cpy : gshortint; int_cp : boolean; { true if last move or line was integer }   world_real_cpx : real; { last move / line cp value } world_real_cpy : real; { define the holders of the locator echo position } { Note that the echo is set by two routines (set_echo_pos, } { calculate_viewing) and both a world cord value and a device cord } { value is kept. This was done since the device dependent value is } { needed as a global value during echoing, yet the world cord value } { is needed as a return value for some 'snap' echoes } w_loc_echo_x : real; { world units } w_loc_echo_y : real; d_loc_echo_x : integer; { device units } d_loc_echo_y : integer; { conversion factors  } xwtod_scale : real; { world to display scale } ywtod_scale : real; xdtow_scale : real; { display to world scale } ydtow_scale : real; xwtod_offset : real; { world to display translation } ywtod_offset : real; xdtow_offset : real; { display to world translation } ydtow_offset : real; xltod_scale : real; { locator to display scale } yltod_scale : real; calc_text_xform : boolean; { true if text xform needs to be recalc } scalef : record { used for int_move / int_line } x_display_delta : gshortint; x_window_delta : gshortint; x_display_offset : gshortint; y_display_delta : gshortint; y_window_delta : gshortint; y_display_offset : gshortint; end; type ls_patterns = packed array [0..7] of gshortint; const raster_patterns = ls_patterns [ -1 {$FFFF} {................ }, { 1 } -256 {$FF00} {........ }, { 2 } -64 {$FFC0} {..........  }, { 3 } -6 {$FFFA} {............. . }, { 4 } -10 {$FFF6} {............ .. }, { 5 } -220 {$FF24} {........ . . }, { 6 } -32640 {$8080} {. . }, { 7 } -21846 {$AAAA} {. . . . . . . . }];{ 8 } var short_flag : boolean; { true if int_move / int_line } { can used fast internal routines } short_defaults : boolean; { true if viewport bounds } { map to max edges of raster display } { input info  } current_echo_type : integer; display_echo_mult : integer; cursor_size_x : integer; cursor_size_y : integer; cursor_color : integer; gle_gcb : graphics_control_block_ptr; gle_gcbi : graphics_input_control_block_ptr; gle_knob_echo_gcb : graphics_control_block_ptr; { for echo on internal crt even if display is moonunit } gcb_space : graphics_control_block1; gle_gcb_space : graphics_control_block; gle_gcbi_space : graphics_input_control_block; gle_knob_echo_gcb_space : graphics_control_block; color_table_def_space : big_color_table_def; poly_table_def_space : poly_table_def; const dno = 0; dyes  = 1; implement end. { of module DGL_VAR } { } { Pascal work station graphics library } { } { Module = DGL_GEN  } { Programer = BJS } { Date = 2/1/81 } { Purpose: To hold most internal routines  } { Rev history } { 6-15-82 BJS - Added moonunit dump graphics stuff } { 7-05-82 BJS - Removed HPGL clipping, now uses ASM_RAS clipp ing } { 7-05-82 BJS - Changes to add 9836C proto support } { 8-25-82 BJS - Major mods for GLE } { 12-20-84 SFB - Added dglfix/dglfloat } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $ref 50$ $include 'OPTIONS'$ $linenum 3000$ $search 'TYPES', 'DGL_VARS', 'GLE_LIB'$ module DGL_GEN; import DGL_TYPES; export procedure error ( error_number : integer ); function min(p1,p2:integer) : integer; function max(p1,p2:integer) : integer; procedure locator_limits (lxmin, lxmax, lymin, lymax : real); procedure calculate_viewing; procedure display_limits ( dxmin, dxmax, dymin, dymax : real); procedure convert_intwtod (x, y : gshortint; var dx, dy : integer ); procedure convert_wtod (x, y : real; var dx, dy : integer ); procedure convert_ltod (lx, ly : integer; var dx, dy : integer ); procedure convert_dtow (dx, dy : integer; var wx, wy : real); procedure ck_system_init; procedure ck_display_init; procedure ck_locator_init; procedure adjust_return_echo ( var rx,ry : real ); function opcode_ck(opcode,num_integer,num_real : integer) : integer; procedure convert_hsl_to_rgb ( hue,sat,lite : real; var r,g,b : real); procedure convert_rgb_to_hsl (r,g,b : real; var hue,sat,lite : real); function dglfloat(anyvar color : gshortint) : real; function dglfix(color : real) : gshortint; function realmap : boolean; implement import asm, dgl_vars, gle_gen, GLE_TYPES; { ************************************************************************** } { } { General procedures and functions } { } { ************************************************************************** } procedure error ( error_number : integer); { Purpose : To log a graphics error, and perform a graphics error escape } begin graphics_error := error_number; escape(graphics_error_number); end; { error } procedure ck_system_init; { Purpose : To report an error if the system is not initialized  } begin if not system_init then error (err_sys_int); end; { ck_sytem_init } procedure ck_display_init; { Purpose : To report an error if the display is not initialized } begin if not disp_init then error (err_dis_int); end; { ck_display_init } procedure ck_locator_init; { Purpose : To report an error if the locator is not initialized } begin if not loc_init then error (err_loc_int); end; { ck_locator_init } function min(p1,p2:integer):integer; { Purpose : To return the minimum of two integers } begin if (p1 >= p2) then min := p2 else min := p1; end; { min } function max(p1,p2:integer):integer; { Purpose : To return the maximum of two integers } begin if (p1 <= p2) then max := p2 else max := p1; end; { max } procedure order_values ( p1,p2 : real; var rp1, rp2 : real); { Purpose : To return the passed in values ordered such that the smaller value is in rp1. } begin if p1 <= p2 then begin rp1 := p1; rp2 := p2; end else begin rp2 := p1; rp1 := p2; end; end; { order_values } function opcode_ck(opcode,num_integer,num_real : integer) : integer; { Purpose: To ck for a v alid opcode passed. Opcodes are all defined such } { that: the hundreds digit = # of reals passed the 1000's digit = # of integers passed This function returns values as follows: = 0 ; ok = 2 ; wrong i size  = 3 ; wrong r size } var digit : array [0..4] of gbyte; i : gshortint; begin for i := 0 to 4 do begin digit[i] := opcode - (opcode div 10) * 10; opcode := opcode div 10; end; opcode_ck := 0; if digit[2] <> num_real then opcode_ck := 3; if digit[3] <> num_integer then opcode_ck := 2; end; procedure convert_hsl_to_rgb ( hue,sat,lite : real; var r,g,b : real); var lx,ly,lz,frac,h : real; j : integer; begin h := 6*hue; j := trunc(h); frac := h-j; lx := lite*(1.0-sat); ly := lite*(1.0-sat*frac); lz := lite*(1.0-sat*(1-frac)); case j of 0,6 : begin r := lite; g := lz; b := lx; end; 1 : begin r := ly; g := lite; b := lx; end; 2 : begin r := lx; g := lite; b := lz; end; 3 : begin r := lx; g := ly; b := lite; end; 4 : begin r := lz; g := lx; b := lite; end; 5 : begin r := lite; g := lx; b := ly; end; end; { of case } end; procedure convert_rgb_to_hsl (r,g,b : real; var hue,sat,lite : real); var x : real; tr,tg,tb : real; function max3(a,b,c : real) : real; begin if (a >= b) and (a >= c) then max3 := a else if (b >= a) and (b >= c) then max3 := b else max3 := c; end; function min3(a,b,c : real) : real; begin if (a <= b) and (a <= c) then min3 := a else if (b <= a) and (b <= c) then min3 := b else min3 := c; end; begin hue := 0; { init values given, since values may be undefined } sat := 1; lite := max3(r,g,b); x := min3(r,g,b); if lite <> 0 then { calc hue and sat only if defined } begin sat := (lite - x) / lite; if sat <> 0 then { calc hue only if defined, other wise defaults to old } begin tr := (lite-r)/(lite-x); tg := (lite-g)/(lite-x); tb := (lite-b)/(lite-x); if r=lite then begin if g=x then hue := 5+tb else hue := 1-tg; end else if g=lite then begin if b=x then hue := 1+tr else hue := 3-tb; end else begin if r=x then hue := 3+tg else hue := 5-tr; end; hue := hue/6; end; end; end; procedure adjust_return_echo ( var rx,ry : real ); { Purpose : adjust return echo values for the effects of rubber band snap } begin case current_echo_type of 5: ry := w_loc_echo_y; { Horizontal rubber band} 6: rx := w_loc_echo_x; { Vertical rubber band } 7: { snap horz / vert rubber band } if abs(rx-w_loc_echo_x) >= abs(ry-w_loc_echo_y) then ry := w_loc_echo_y else rx := w_loc_echo_x; otherwise ; { no adjustment needed for others } end; { of case } end; { adjust_return_echo } { ************************************************************************** } { } { General Viewing transformation routines } {  } { ************************************************************************** } procedure convert_intwtod( x,y: gshortint; var dx,dy: integer); { Purpose : To convert form world to display cord } var tx, ty : integer; lx,ly : gshortint; begin if short_defaults then begin dx := x; dy := y; end else with scalef do begin tx := x * x_display_delta; lx := tx div x_window_delta + x_display_offset; ty := y * y_display_delta; ly := ty div y_window_delta + y_display_offset; dx := lx; dy := ly; end; end; { convert_intwtod } procedure convert_wtod( x,y:real; var dx,dy:integer); { Purpose : To convert form world to display cord } begin dx := trunc(x * xwtod_scale + xwtod_offs et); dy := trunc(y * ywtod_scale + ywtod_offset); {WRITELN('WTOD (',X:8:5,Y:8:5,')=',DX:8,DY:8);} end; { convert_wtod } procedure convert_ltod( lx,ly : integer; var dx,dy : integer ); { Purpose : To convert from locator to display units } begin with gcb^ do begin dx := trunc( ((lx - log_loc_lim.xmin) * xltod_scale) + cur_disp_lim.xmin + 0.5); dy := trunc( ((ly - log_loc_lim.ymin) * yltod_scale) + cur_disp_lim.ymin + 0.5); end; end; { convert_ltod } procedure convert_dtow( dx,dy : integer; var wx,wy : real); { Purpose : To convert from display to world units } begin wx := (dx + xdtow_offset) * xdtow_scale; wy := (dy + ydtow_offset) * ydtow_scale; end; { convert_dtow } procedure locator_limits (lxmin,lxmax, lymin,lymax : real); { Purpose : To set the locator limits ( in device units ) } { Note: This routine does not perform error cking } begin with gcb^ do begin { set the logical limits } with log_loc_lim do begin xmin := lxmin; xmax := lxmax; ymin := lymin; ymax := lymax; end; { calculate the display / locator xforms } xltod_scale := (cur_disp_lim.xmax - cur_disp_lim.xmin) / (log_loc_lim.xmax - log_loc_lim.xmin); yltod_scale := (cur_disp_lim.ymax - cur_disp_lim.ymin) / (log_loc_lim.ymax - log_loc_lim.ymin); { set the locator echo position to the center of the window } with window_lim do begin w_loc_echo_x := ((xmax - xmin) / 2.0) + xmin; w_loc_echo_y := ((ymax - ymin) / 2.0) + ymin; end; { convert to device units } convert_wtod ( w_loc_echo_x, w_loc_echo_y, d_loc_echo_x, d_loc_echo_y ); end; end; { locator_limits } procedure calculate_viewing; { Purpose : To calculate a new viewing transformation } var temp : real; { temp work var } procedure int_test; { Purpose : To see if conditions are right, and setup if so, for int_move and int_line to call fast integer device routines } var sxmin : integer; sxmax : integer; symin : integer; symax : integer; gsxmin : gshortint; gsxmax : gshortint; gsymin : gshortint; gsymax : gshortint; window_delta_x : integer; window_delta_y : integer; begin short_flag := false; with gcb^ do begin if disp_init then try $range on$ { range cking done here } { find device points for the corners of the window } convert_wtod(window_lim.xmin,window_lim.ymin,sxmin,symin); convert_wtod(window_lim.xmax,window_lim.ymax,sxmax,symax); { convert to non-fix point form } gsxmin := sxmin; gsxmax := sxmax; gsymin := symin; gsymax := symax; {set up scale info } with window_lim do begin window_delta_x := trunc(xmax) - trunc(xmin); window_delta_y := trunc(ymax) - trunc(ymin); { ck delta window values in range } if (abs(window_delta_x) > 32767) or (abs(window_delta_y) > 32767) then escape(-4); { force integer overflow } with scalef do begin x_display_delta := gsxmax - gsxmin; x_window_delta := window_delta_x; x_display_offset := ((-trunc(xmin) * x_display_delta) div x_window_delta) + gsxmin; y_display_delta := gsymax - gsymin; y_window_delta := window_delta_y; y_display_offset := ((-trunc(ymin) * y_display_delta) div y_window_delta) + gsymin; if (x_display_offset = 0) and (x_window_delta = x_display_delta) and (y_display_offset = 0) and (y_window_delta = y_display_delta) then short_defaults := true else short_defaults := false; end; end; short_flag := true; recover { can't use int_move / int_line internal routines } if (escapecode > -4) or { igonor all math and range errors } (escapecode < -8) then escape(escapecode); $range off$ end; end; { of procedure int_test } begin with gcb^ do begin { set view surface limi ts to the logical display limits } cur_disp_lim := log_disp_lim; { if desired aspect = aspect of logical limits then we don't need to redefine the limits as set above } if (aspect_ratio <> log_aspect) then begin {determine which device limits to change} if (aspect_ratio <= log_aspect) then begin {check display justification} if (disp_just = centered) then {set vertical limits for device on which view space is centered within the logical display limits } begin temp := 0.5 * (dyunits - (dxunits * aspect_ratio) ); cur_disp_lim.ymin := log_disp_lim.ymin + temp; cur_disp_lim.ymax := log_disp_lim.ymax - temp; end else { not centered } {set vertical limits for device on which view space is lower left justified within the logical display limits } begin cur_disp_lim.ymax := log_disp_lim.ymin + (dxunits * aspect_ratio); end; end else { current aspect ratio > aspect ratio of logical limits } begin {check display justification} if (disp_just = centered) then {set horizontal limits for device on which view space is centered within the logical display limits } begin temp := 0.5 * (dxunits - (dyunits / aspect_ratio) ); cur_disp_lim.xmin := log_disp_lim.xmin + temp; cur_disp_lim.xmax := log_disp_lim.xmax - temp; end else { not centered } {set horizontal limits for device on which view space is lower left justified within the logical display limits } begin cur_disp_lim.xmax := log_disp_lim.xmin + (dyunits / aspect_ratio); end; end; end; { set clipping limits here } if disp_init then with gle_gcb^,cur_disp_lim do begin {WRITELN('C =',XMIN:19:18,XMAX:19:18,YMIN:19:18,YMAX:19:18); WRITELN('CI=',TRUNC(XMIN+0.5):19,TRUNC(XMAX+0.5):19, TRUNC(YMIN+0.5):19,TRUNC(YMAX+0.5):19);} info1 := trunc(xmin+0.5); info2 := trunc(xmax+0.5); info3 := trunc(ymin+0.5); info4 := trunc(ymax+0.5); gle_clip_limits (gle_gcb); end; { recalculate the world to display transformation constants } { x scale and offset  } with cur_disp_lim do temp := (xmax - xmin ) / cur_vir_lim.xlim; xwtod_scale := temp * ((viewport_lim.xmax - viewport_lim.xmin) / (window_lim.xmax - window_lim.xmin)); xwtod_offset := cur_disp_lim.xmin + (viewport_lim.xmin * temp) - (window_lim.xmin * xwtod_scale); xdtow_scale := 1.0 / xwtod_scale; xdtow_offset := - xwtod_offset; xwtod_offset := xwtod_offset + 0.5 {0.00000001}; { y scale and offset  } with cur_disp_lim do temp := (ymax - ymin ) / cur_vir_lim.ylim; ywtod_scale := temp * ((viewport_lim.ymax - viewport_lim.ymin) / (window_lim.ymax - window_lim.ymin)); ywtod_offset := cur_disp_lim.ymin + (viewport_lim.ymin * temp) - (window_lim.ymin * ywtod_scale); ydtow_scale := 1.0 / ywtod_scale; ydtow_offset := - ywtod_offset; ywtod_offset := ywtod_offset + 0.5 {0.00000001}; if disp_eq_loc then begin {if display and locator are the same physical device then set the locator limits to the display limits } with cur_disp_lim do locator_limits(xmin,xmax,ymin,ymax); end else begin {set the locator limits to current locator limits  } with log_loc_lim do locator_limits(xmin,xmax,ymin,ymax); end; { set up for int_move / int_line scale } int_test; end; end; { calculate_viewing } procedure display_limits ( dxmin, dxmax, dymin, dymax : real ); { Purpose : To set the logical display limits in device units } begin {WRITELN('NEW DISPLAY LIM = ',DXMIN:19:18,DXMAX:19:18,DYMIN:19:18,DYMAX:19:18); } with gcb^ do begin { set new log limits } with log_disp_lim do begin xmin := dxmin;   xmax := dxmax; ymin := dymin; ymax := dymax; end; { set the display width and height } dxunits := dxmax - dxmin; dyunits := dymax - dymin; { calculate aspect ratio of new log lim } log_aspect := dyunits / dxunits; { set up new viewing transformation } calculate_viewing; end; end; { display_limits } function realmap : boolean; begin realmap := true; with gle_gcb^ do if (display_name = '98700A') or (display_name = '98542A') or (display_name = '98543A') or (display_name = '98544A') or (display_name = '98545A') or (display_name = '98547A') or (display_name = '98548A') {SFB 2/2/88} or (display_name = '98549A') or (display_name = '98550A') {SFB 2/2/88} or (display_name = 'E640 ') or (display_name = 'E1024 ') {CFB 30JUL91} or (display_name = 'E1280 ') or (display_name = 'E640G ') {CFB 30JUL91} or (display_name = 'E1280G') then {CFB 30JUL91} realmap := false; end; function dglfloat(anyvar color : gshortint) : real; var temp : ^real; begin if not realmap then dglfloat := color / 32767 else begin temp := addr(color); dglfloat := temp^; end; end; function dglfix(color : real) : gshortint; begin dglfix := ROUND(color * 32767); end; end. { of module DGL_GEN } * * Graphics Low End * * Module = GLE_AUTL * Programer = BJS * Date = 9/30/82 * * Purpose : To provide low level bit operations for GLE * * Rev history * * Created - 9/30/82 * Modified - * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * MNAME GLE_AUTL src MODULE GLE_AUTL; src EXPORT src FUNCTION GLE_IAND (VALUE1, VALUE2 : INTEGER) : INTEGER; src FUNCTION GLE_IOR (VALUE1, VALUE2 : INTEGER) : INTEGER; src FUNCTION GLE_ISHIFT (VALUE, SHIFT : INTEGER) : INTEGER; src END; rorg 0 def GLE_AUTL_GLE_ISHIFT def GLE_AUTL_GLE_IAND def GLE_AUTL_GLE_IOR def GLE_AUTL_GLE_AUTL nosyms ****************************************************************************** * * T := GLE_ISHIFT ( VALUE, SHIFT ) * * This function shifts VALUE right (if SHIFT is negative) or left ( if * SHIFT is positive) by ABS(SHIFT). * GLE_AUTL_GLE_ISHIFT equ * link a6,#0 move.l 12(a6),d0 value to shift move.l 8(a6),d1 shift value tst.l d1 blt.s shift_right asl.l d1,d0 bra.s shift_done shift_right equ * neg.l d1 asr.l d1,d0 shift_done equ *  move.l d0,16(a6) unlk a6 return to pascal movea.l (sp)+,a0 addq.w #8,sp jmp (a0) ****************************************************************************** * * T := GLE_IAND ( VALUE1, VALUE2 ) * * This function and's VALUE1 with VALUE2. * GLE_AUTL_GLE_IAND equ * link a6,#0 move.l 12(a6),d0 value2 move.l 8(a6),d1 value1 and.l d1,d0 perform operation move.l d0,16(a6) put result on stack unlk a6 return to pascal movea.l (sp)+,a0 addq.w #8,sp jmp (a0) ****************************************************************************** * * T := GLE_IOR ( VALUE1, VALUE2 ) * * This  function OR's VALUE1 with VALUE2. * GLE_AUTL_GLE_IOR equ * link a6,#0 move.l 12(a6),d0 value2 move.l 8(a6),d1 value1 or.l d1,d0 perform operation move.l d0,16(a6) put result on stack unlk a6 return to pascal movea.l (sp)+,a0 addq.w #8,sp jmp (a0) GLE_AUTL_GLE_AUTL RTS module init procedure { } { Graphics Low End } { } { Module = GLE_FILE } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide general file drivers for ascii device handlers. } { Rev history } { Created - 10-10-82  } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $SEARCH 'GLE_TYPES','GLE_UTLS'$ $modcal$ $include 'OPTIONS'$ { ***************** COMPILER OPTIONS ***************** } $LINENUM 9000$ module gle_file_io; import gle_types; export type file_iocb_ptr = ^file_iocb; file_iocb = record file_name : anyptr; name_size : gle_shortint; output_file : text; lock_on_close : gle_shortint; { 1 = lock } end; procedure file_init ( anyvar iocb_ptr : anyptr ); procedure file_write ( anyvar iocb_ptr, data_ptr : anyptr ); procedure file_inq_timeout ( anyvar iocb_ptr: anyptr; var value : integer ); procedure file_set_timeout ( anyvar iocb_ptr: anyptr; value : integer ); procedure file_term ( anyvar iocb_ptr : anyptr ); implement import gle_utls; { The following types must match the types declared in GLE_HPGL, GLE_HPGLI } type ascii_buffer_ptr = ^ascii_buffer; ascii_buffer = packed record maximum : integer; current : integer; data : packed array [1..32767] of char; end; procedure file_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer ); { Dummy procedures for file io } begin end; procedure file_set_timeout ( anyvar iocb_ptr : anyptr; value : integer ); { Dummy procedures for file io } begin end; procedure file_init ( anyvar iocb_ptr : anyptr ); var name : string[255]; begin with file_iocb_ptr(iocb_ptr)^ do begin gle_copy_to_string(file_name,name_size,name); rewrite(output_file,name); end; end; procedure file_write ( anyvar iocb_ptr, data_ptr : anyptr ); begin with file_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do begin writeln(output_file,data:current); current := 0; end; end; procedure file_term ( anyvar iocb_ptr : anyptr ); begin with file_iocb_ptr(iocb_ptr)^ do begin if lock_on_close = 1 then close (output_file,'lock') else close (output_file); end; end; end. { of module gle_file_io }  { } { Graphics Low End } { } { Module = GLE_GEN  } { Programer = BJS } { Date = 10- 5-82 } {  } { Purpose: To provide an interface between the GLE caller and the procedure } { variables in the GCB. The module also initializes the GCB. } { Rev history  } { Created - 10- 5-82 } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government  is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $search 'GLE_TYPES'$ $include 'OPTIONS'$ { ****************** compiler options ****************** } $linenum 2000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module gle_gen; import gle_types; export procedure gle_move ( gcb : graphics_control_block_ptr ); procedure gle_draw ( gcb : graphics_control_block_ptr ); procedure gle_text ( gcb : graphics_control_block_ptr ); procedure gle_char_size ( gcb : graphics_control_block_ptr ); procedure gle_text_spacing ( gcb : graphics_control_block_ptr ); procedure gle_text_dir ( gcb : graphics_control_block_ptr ); procedure gle_text_just ( gcb : graphics_control_block_ptr ); procedure gle_marker ( gcb : graphics_control_block_ptr ); procedure gle_index_color ( gcb : graphics_control_block_ptr ); procedure gle_clear ( gcb : graphics_control_block_ptr ); procedure gle_clip_limits ( gcb : graphics_control_block_ptr ); procedure gle_init_gcb  ( gcb : graphics_control_block_ptr ); procedure gle_get_p1p2 ( gcb : graphics_control_block_ptr ); procedure gle_get_polygon_info ( gcb : graphics_control_block_ptr ); procedure gle_set_marker ( gcb : graphics_control_block_ptr ); procedure gle_marker_size ( gcb : graphics_control_block_ptr ); procedure gle_flush_buffer ( gcb : graphics_control_block_ptr ); procedure gle_term ( gcb : graphics_control_block_ptr ); procedure gle_cursor ( gcb : graphics_control_block_ptr ); procedure gle_polygon ( gcb : graphics_control_block_ptr ); procedure gle_fill_index_color ( gcb : graphics_control_block_ptr ); procedure gle_define_color_map ( gcb : graphics_control_block_ptr ); procedure gle_define_drawing_mode ( gcb : graphics_control_block_ptr ); procedure gle_linestyle ( gcb : graphics_control_block_ptr ); procedure gle_linewidth ( gcb : graphics_control_block_ptr ); procedure gle_buffer_mode ( gcb : graphics_control_block_ptr ); procedure gle_graphics_on_off ( gcb : graphics_control_block_ptr ); procedure gle_gload ( gcb : graphics_control_block_ptr ); procedure gle_gstore ( gcb : graphics_control_block_ptr ); procedure gle_get_raster ( gcb : graphics_control_block_ptr ); procedure gle_get_color_map ( gcb : graphics_control_block_ptr ); procedure gle_output_escapei ( gcb : graphics_control_block_ptr ); procedure gle_output_escapeo ( gcb : graphics _control_block_ptr ); procedure gle_await_blanking ( gcb : graphics_control_block_ptr ); implement procedure gle_output_escapeo ( gcb : graphics_control_block_ptr ); begin call (gcb^.output_escapeo,gcb); end; procedure gle_output_escapei ( gcb : graphics_control_block_ptr ); begin call (gcb^.output_escapei,gcb); end; procedure gle_move ( gcb : graphics_control_block_ptr ); begin call (gcb^.move,gcb); end; procedure gle_draw ( gcb : graphics_control_block_ptr ); begin call (gcb^.draw,gcb); end; procedure gle_text ( gcb : graphics_control_block_ptr ); begin call (gcb^.text,gcb); end; procedure gle_char_size ( gcb : graphics_control_block_ptr ); begin call (gcb^.char_size,gcb); end; procedure gle_text_spacing ( gcb : graphics_control_block_ptr ); begin call (gcb^.text_spacing,gcb); end; procedure gle_text_dir ( gcb : graphics_control_block_ptr ); begin call (gcb^.text_dir,gcb); end; procedure gle_clear ( gcb : graphics_control_block_ptr ); begin call (gcb^.clear,gcb); end; procedure gle_text_just ( gcb : graphics_control_block_ptr ); begin call (gcb^.text_dir,gcb); end; procedure gle_marker ( gcb : graphics_control_block_ptr ); begin call (gcb^.marker,gcb); end; procedure gle_index_color ( gcb : graphics_control_block_ptr ); begin call (gcb^.index_color,gcb); end; procedure gle_clip_limits ( gcb : graphics_control_block_ptr ); begin call (gcb^.clip_limits,gcb); end; procedure gle_init_gcb ( gcb : graphics_control_block_ptr ); begin with gcb^ do begin display_name_char_count := 0; display_handler_char_count := 0; iocb := nil; device_buf := nil; dev_dep_stuff := nil; device_info := nil; error_return := 0; spooling := 0; end; end; procedure gle_get_polygon_info ( gcb : graphics_control_block_ptr ); begin call(gcb^.get_polygon_info,gcb); end; procedure gle_get_p1p2 ( gcb : graphics_control_block_ptr ); begin call(gcb^.inq_p1p2,gcb); end; procedure gle_set_marker ( gcb : graphics_control_block_ptr ); begin call(gcb^.set_marker,gcb); end; procedure gle_marker_size ( gcb : graphics_control_block_ptr ); begin call(gcb^.marker_size,gcb); end; procedure gle_flush_buffer( gcb : graphics_control_block_ptr ); begin with gcb^ do call(gcb^.flush_buffer,gcb); end; procedure gle_term ( gcb : graphics_control_block_ptr ); begin with gcb^ do call(io_term, iocb); end; procedure gle_cursor ( gcb : graphics_control_block_ptr ); begin call (gcb^.cursor,gcb); end; procedure gle_polygon ( gcb : graphics_control_block_ptr ); begin call (gcb^.polygon,gcb); end; procedure gle_fill_index_color ( gcb : graphics_control_block_ptr ); begin call (gcb^.fill_index_color,gcb); end; procedure gle_define_color_map( gcb : graphics_control_block_ptr ); begin call (gcb^.define_color_map,gcb); end; procedure gle_define_drawing_mode ( gcb : graphics_control_block_ptr ); begin call (gcb^.define_drawing_mode,gcb); end; procedure gle_linestyle ( gcb : graphics_control_block_ptr ); begin call (gcb^.linestyle,gcb); end; procedure gle_linewidth ( gcb : graphics_control_block_ptr ); begin call (gcb^.linewidth,gcb); end; procedure gle_buffer_mode ( gcb : graphics_control_block_ptr ); begin call (gcb^.buffer_mode,gcb); end; procedure gle_graphics_on_off ( gcb : graphics_control_block_ptr ); begin call (gcb^.graphics_on_off,gcb); end; procedure gle_gload ( gcb : graphics_control_block_ptr ); begin call (gcb^.gload,gcb); end; procedure gle_gstore ( gcb : graphics_control_block_ptr ); begin call (gcb^.gstore,gcb); end; procedure gle_get_raster ( gcb : graphics_control_block_ptr ); begin call (gcb^.get_raster,gcb); end; procedure gle_get_color_map ( gcb : graphics_control_block_ptr ); begin call (gcb^.get_color_map,gcb); end; procedure gle_await_blanking ( gcb : graphics_control_block_ptr ); begin call (gcb^.await_blanking,gcb); end; end. { of module gle_gen }  { } { Graphics Low End } { } { Module = GLE_GENI } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide interface procedure to the procedure variables in } { the GCB and to provide GCB initialization. } { Rev history  } { Created - 10-10-82 } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government  is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_TYPES'$ $modcal$ $include 'OPTIONS'$ { ****************** COMPILER OPTIONS ****************** } $linenum 3000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module gle_geni; import gle_types; export procedure gle_init_input_gcb ( gcbi : graphics_input_control_block_ptr ); procedure gle_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); procedure gle_input_term ( gcbi : graphics_input_control_block_ptr ); procedure gle_input_echo ( gcbi : graphics_input_control_block_ptr ); procedure gle_input_escapei ( gcbi : graphics_input_control_block_ptr ); procedure gle_input_escapeo ( gcbi : graphics_input_control_block_ptr ); procedure gle_sample ( gcbi : graphics_input_control_block_ptr ); procedure gle_start_digitize ( gcbi : graphics_input_control_block_ptr ); procedure gle_get_digitize ( gcbi : graphics_input_control_block_ptr ); implement procedure gle_init_input_gcb ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do begin input_name_char_count := 0; input_handler_char_count := 0; iocb := nil; device_buf := nil; dev_dep_stuff := nil; device_info := nil; error_return := 0; end; end; procedure gle_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); begin call(gcbi^.inq_p1p2,gcbi); end; procedure gle_input_term ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do call(io_term, iocb); end; procedure gle_input_echo ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.input_echo,gcbi); end; procedure gle_input_escapei ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.input_escapei,gcbi); end; procedure gle_input_escapeo ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.input_escapeo,gcbi); end; procedure gle_sample ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.sample,gcbi); end; procedure gle_start_digitize ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.start_digitize,gcbi); end; procedure gle_get_digitize ( gcbi : graphics_input_control_block_ptr ); begin call (gcbi^.get_digitize,gcbi); end; end. { of module gle_geni } { } { Graphics Low End } { } { Module = GLE_HPHI L_ABSI } { Programer = SFB } { Date = 3/20/85 } {  } { Purpose: To provide HPHIL absolute locator input handler routines. } { Rev history } { Created - 3-20-85  } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $SEARCH 'GLE_TYPES','GLE_UTLS'$ $modcal$ $DEBUG OFF$ $INCLUDE 'OPTIONS'$ { ******************* COMPILER OPTIONS ******************* } $LINENUM 18000$ $ALLOW_PACKED ON$ {SFB 4/11/85} module gle_hphil_absi; import gle_types, sysdevs; export var dvr_rec : hphil_comm_rec_ptr_type; procedure gle_init_hphil_abs_input ( gcbi : graphics_input_control_block_ptr); implement import gle_utls, iocomasm; var xdev, ydev : integer; procedure hphil_abs_input_escapeo ( gcbi : graphics_input_control_block_ptr ); begin { with gcbi^ do begin end; } end; procedure hphil_abs_input_escapei ( gcbi : graphics_input_control_block_ptr ); begin { with gcbi^ do begin end; } end; procedure hphil_abs_get_input_hard_clip(gcbi : graphics_input_control_block_ptr ); var i, w,h : integer; found : boolean; begin w := 0; h := 0; found := false; with gcbi^ do begin xdev := 0; ydev := 0; for i:=1 to 7 do {find limits of largest active abs locator} with loopcontrol^.loopdevices[i].descrip, dvr_rec^ do if (abscoords) and (bit_set(devices, i-1)) then {only active devices} begin found := true;  if maxcountx > w then begin w := maxcountx; xdev := i; end; if maxcounty > h then begin h := maxcounty; ydev := i; end; end; if not found then escape(-26) else begin info1 := 0; info2 := w; info3 := 0; info4 := h; end; end; end; procedure hphil_abs_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); begin {set p1, p2 to hard clip limits for hphil abs locators} hphil_abs_get_input_hard_clip(gcbi); end;  procedure read_hphil_abs(var x, y : integer; var button : integer); begin with dvr_rec^ do begin reading := true; {tell driver not to update dvr_comm_rec} x := xloc; y := yloc; button := -1; if ncodes > 0 then  {pick up first button encountered only} button := ord(codes[1]); call(update, dvr_rec); reading := false; end; end; procedure hphil_abs_sample ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^, dvr_rec^ do begin read_hphil_abs(info1, info2, info3); input_cpx := info1; input_cpy := info2; end; end; procedure hphil_abs_start_digitize ( gcbi : graphics_input_control_block_ptr ); begin with dvr_rec^ do begin reading := true; {tell driver not to interfere} ncodes := 0; {cancel previous buttons} latch := true; {in await_locator} active := true; {ensure we're now sampling} call(update, dvr_rec); {flush any pending dvr data to dvr_comm_rec} reading := false; {let driver update record with future data} end; end; procedure hphil_abs_get_digitize ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do read_hphil_abs(info1, info2, info3); with dvr_rec^ do {er ase from driver the button read into info3} begin reading := true; {tell driver not to interfere} ncodes := 0; {cancel button read} latch := false; {allow updates w/new driver data} call(update,dvr_rec); {flush any pending driver data} reading := false; {allow driver updates} end; end; procedure hphil_abs_input_echo ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do if info1 <> 0 then begin beep; {use 8042 (HPHIL controller) beeper for echo 1} end; end; procedure gle_init_hphil_abs_input ( gcbi : graphics_input_control_block_ptr); begin with gcbi^ do begin error_return := 0; dvr_rec := gcbi^.info_ptr1; {get comm_rec_ptr from DGL_CONFIG_IN} dvr_rec^.extend := 1; {tell ABS driver to set proximity true at next update} {-1 would be "set proximity false", and 0 is "don't touch proximity"} try {check for device actually attached to abs driver} hphil_abs_get_input_hard_clip ( gcbi ); {escapes if no locator} {to get here there was at least one abs locator found on HPHIL. The configure operation in the HPHIL module will have got the loopdriver connected to all abslocators with IDs in proper range.}  with dvr_rec^ do begin reading := true; {tell driver not to interfere} ncodes := 0; {toss any previous buttons} latch := false; {disarm the digitize function} active := true; {allow driver to start acquiring data} reading := false; {and sending to dvr_rec} end; sample := hphil_abs_sample; start_digitize := hphil_abs_start_digitize; get_digitize := hphil_abs_get_digitize; inq_p1p2 := hphil_abs_get_input_p1p2; input_echo := hphil_abs_input_echo; input_escapei := hphil_abs_input_escapei; input_escapeo := hphil_abs_input_escapeo; input_handler_name := 'HILABS'; input_handler_char_count := 6; input_name := 'HILABS'; {3.1 bug SFB 09/15/86} input_name_char_count := 6; {3.1 bug SFB 09/15/86} input_min_x := info1; input_max_x := info2; input_min_y := info3; input_max_y := info4; input_cpx := input_min_x; input_cpy := input_min_y; with loopcontrol^.loopdevices[xdev].descrip do begin if size16 then input_res_x := counts/10.0 else input_res_x := counts/1000.0; end; with loopcontrol^.loopdevices[ydev].descrip do begin if size16 then input_res_y := counts/10.0 else input_res_y := counts/1000.0; end; recover if escapecode = -26 then error_return := 1 {hphil_abs_get_input_hard_clip failed, so no locator on loop} else escape(escapecode);  {other error encountered in init} end; {with gcbi^} end; end. { hpgl_input } { } { Graphics Low End } { } { Module = GLE_HPGL_OUT } { Programer = BJS } { Date = 10- 5-82 } {  } { Purpose: To provide device dependent routines to drive hpgl output } { plotters. } { Rev history  } { Created - 10- 5-82 BJS } { Modified - 11-24-82 BJS removed refs to str routines } { 6-28-83 BJS added import of gle_astext (routine moved from } {   gle_stext } { 3-14-84 BDS added identifiers for 7586B, 7550A, 7090, 7440 } { 4- -85 SFB bug fixes for some string lengths } { 4-23-85 SFB pass out all escape codes after current := 0 } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_TYPES', 'GLE_SCLIP', 'ASM_SCLIP', 'GLE_STEXT', 'ASM_STEXT', 'GLE_SMARK', 'GLE_UTLS'$ $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 7000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module GLE_HPGL_OUT; import gle_types; export const max_buffer = 255; buffer_fudge = 32; type ascii_buffer_ptr = ^ascii_buffer; ascii_buffer = packed record maximum : integer; current : integer; data : packed array [1..max_buffer] of char; end; driver_state_def = (moving,drawing,start_of_buffer,unknown); hpgl_device_rec_ptr= ^ hpgl_device_rec; hpgl_device_rec = record driver_state : driver_state_def; end; procedure gle_init_hpgl_output ( gcb : graphics_control_block_ptr ); implement import gle_stext, gle_astext, gle_asclip, gle_sclip, gle_smark,  gle_utls; procedure hpgl_flush_buffer ( gcb : graphics_control_block_ptr ); begin with gcb^, ascii_buffer_ptr(device_buf)^, hpgl_device_rec_ptr(dev_dep_stuff)^ do begin if current <> 0 then call (io_write,iocb,device_buf);  driver_state := start_of_buffer; end; end; procedure dummy ( gcb : graphics_control_block_ptr ); begin end; procedure buffer_cleanup ( gcb : graphics_control_block_ptr ); begin with gcb^,ascii_buffer_ptr(gcb^.device_buf)^ do if (current > maximum - buffer_fudge) or (current_buffer_mode = 0) then hpgl_flush_buffer ( gcb ); end; procedure add_char_data ( gcb : graphics_control_block_ptr; count : gle_shortint; s : anychar_ptr ); var i : gle_shortint; begin with gcb^,ascii_buffer_ptr(gcb^.device_buf)^ do begin for i := 1 to count do data[i+current] := s^[i]; current := current + count; end; end; procedure add_parm_data ( gcb : graphics_control_block_ptr; value : gle_shortint); var count : gle_shortint; begin with gcb^,ascii_buffer_ptr(gcb^.device_buf)^ do begin gle_write_integer (value,count,addr(data[current+1])); current := current + count; end; end; procedure change_state ( gcb : graphics_control_block_ptr; new_state : driver_state_def ); var change : boolean; begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ do begin change := new_state <> driver_state; if (driver_state = unknown) or (((driver_state = moving) or (driver_state = drawing)) and change) then add_char_data(gcb,1,addr('; ')); if change then begin driver_state := new_state; case driver_state of moving : add_char_data ( gcb, 5, addr('PU;PA') ); drawing : add_char_data ( gcb, 5, addr('PD;PA') ); start_of_buffer,unknown : ; end; { of case } end; end; end; procedure hpgl_output_escapeo ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(gcb^.device_buf)^do begin try  change_state ( gcb, unknown ); add_char_data(gcb,info1,anyptr(info_ptr1)); buffer_cleanup ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end;  end; procedure hpgl_output_escapei ( gcb : graphics_control_block_ptr ); var i : gle_shortint; sptr : anychar_ptr; begin with gcb^,ascii_buffer_ptr(gcb^.device_buf)^ do begin try call (io_read, iocb, device_buf); sptr := anyptr(info_ptr1); info1 := current; for i := 1 to current do sptr^[i] := data[i]; current := 0; { reset buffer counter } recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_get_p1p2 ( gcb : graphics_control_block_ptr ); var cnt : gle_shortint; tcnt : gle_shortint; temp : integer; begin with gcb^, ascii_buffer_ptr(gcb^.device_buf)^, hpgl_device_rec_ptr(dev_dep_stuff)^ do begin try if spooling = 0 then begin change_state ( gcb, unknown ); add_char_data ( gcb, 2, addr('OP') ); hpgl_flush_buffer ( gcb ); call (io_read, iocb, device_buf); tcnt := 1; info1 := gle_read_integer (current,addr(data[1]),cnt); cnt := cnt + tcnt; info3 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info2 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info4 := gle_read_integer (current,addr(data[cnt]),tcnt); current := 0; if info1 > info2 then { make xmin <= xmax } begin temp := info1; info1 := info2; info2 := temp; end; if info3 > info4 then { make ymin <= ymax } begin temp := info3; info3 := info4; info4 := temp; end; end else begin info1 := display_min_x; info2 := display_max_x; info3 := display_min_y; info4 := display_max_y; end; recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_get_hard_clip ( gcb : graphics_control_block_ptr ); var tcnt,cnt : gle_shortint; tp1x,tp1y,tp2x,tp2y : gle_shortint; begin with gcb^, ascii_buffer_ptr(gcb^.device_buf)^, hpgl_device_rec_ptr(dev_dep_stuff)^ do begin try if gle_match(4,addr(display_name),4,addr('7580')) or gle_match(4,addr(display_name),4,addr('7585')) or gle_match(4,addr(display_name),4,addr('7586')) or  gle_match(4,addr(display_name),4,addr('7595')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7596')) or {SFB 9/22/86} gle_match(4,addr(display_name),4,addr('7570')) or {SFB 9/18/86} gle_match(4,addr(display_name),4,addr('7575')) or {SFB 11/14/88} gle_match(4,addr(display_name),4,addr('7576')) then {SFB 11/14/88} begin if spooling = 0 then begin add_char_data ( gcb, 2, addr('OH') ); hpgl_flush_buffer ( gcb ); call (io_read, iocb, device_buf); tcnt := 1; info1 := gle_read_integer (current,addr(data[1]),cnt); cnt := cnt + tcnt; info3 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info2 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info4 := gle_read_integer (current,addr(data[cnt]),tcnt); current := 0; end else begin if ( gle_match(4,addr(display_name),4,addr('7586')) ) or ( gle_match(4,addr(display_name),4,addr('7585')) ) or ( gle_match(4,addr(display_name),4,addr('7596')) ) or {SFB 9/22/86} ( gle_match(4,addr(display_name),4,addr('7595')) ) or {SFB 9/22/86} ( gle_match(4,addr(display_name),4,addr('7576')) ) then {SFB 11/14/88}  begin info1 := -23656; { E size } info2 := 23656; info3 := -17962; info4 := 17962; end else {7580x or 7570A or 7575A (11/14/88) spooling SFB 9/18/86} begin info1 := -16190; { D size } info2 := 16190; info3 := -10485; info4 := 10485; end; end end else if (gle_match(4,addr(display_name),4,addr('7470'))) or (gle_match(4,addr(display_name),4,addr('7440'))) then begin i nfo1 := 0; info2 := 10300; info3 := 0; info4 := 7650; end else if (gle_match(4,addr(display_name),4,addr('7475'))) or (gle_match(4,addr(display_name),4,addr('7090'))) then begin info1 := 0; info2 := 16640; info3 := 0; info4 := 10365; end else if gle_match(4,addr(display_name),4,addr('7550')) then begin info1 := 0; info2 := 16450; info3 := 0; info4 := 10170; end else if gle_match(4,addr(display_name),4,addr('9872')) or (spooling = 1) then begin info1 := 0; info2 := 16000; info3 := 0; info4 := 11400; end else begin { initialize the device and use P1/P2 values } hpgl_get_p1p2 ( gcb ); tp1x := info1; tp2x := info2; tp1y := info3; tp2y := info4; add_char_data ( gcb, 3, addr('IN')); hpgl_flush_buffer ( gcb ); { BDS 3/28/84 } hpgl_get_p1p2 ( gcb ); { restore p1, p2 } add_char_data ( gcb, 2, addr('IP')); add_parm_data ( gcb, tp1x ); add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, tp1y ); add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, tp2x ); add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, tp2y ); hpgl_flush_buffer ( gcb ); end; recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_move ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(device_buf)^ do begin try if driver_state = moving then add_char_data ( gcb, 1, addr(', ')) else change_state ( gcb, moving ); add_parm_data ( gcb, end_x); add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, end_y); current_pos_x := end_x; current_pos_y := end_y; buffer_cleanup ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_draw ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(device_buf)^ do begin try if driver_state = drawing then add_char_data ( gcb, 1, addr(', ')) else change_state ( gcb, drawing ); add_parm_data ( gcb, end_x);  add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, end_y); current_pos_x := end_x; current_pos_y := end_y; buffer_cleanup ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0;  escape(escapecode); end; end; end; procedure hpgl_buffer_mode( gcb : graphics_control_block_ptr ); begin with gcb^ ,ascii_buffer_ptr(device_buf)^ do begin try hpgl_flush_buffer ( gcb ); current_buffer_mode := info1; recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_set_color ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(gcb^.device_buf)^ do begin try change_state ( gcb, unknown ); add_char_data ( gcb, 5, addr('PU;SP') ); add_parm_data ( gcb, info1 ); buffer_cleanup ( gcb ); current_color_index := info1; recover begin  {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; {********************** this procedure is never used *********************** procedure hpgl_fill_index_color ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ do current_polygon_color := info1; end;} procedure hpgl_linestyle ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(gcb^.device_buf)^ do begin try change_state ( gcb, unknown ); current_linestyle := info1; current_pattern_length := info2; current_linestyle_mode := info3; current_linestyle_pattern := info4; add_char_data( gcb,2,addr('LT')); if info1 = 0 then begin end else if info1 = 7 then add_parm_data(gcb,0) else begin if info3 = 0 then add_parm_data(gcb,info1) else add_parm_data(gcb,-info1); add_char_data(gcb,1,addr(', ')); add_parm_data(gcb,info2); end; buffer_cleanup ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_clear( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(gcb^.device_buf)^do begin try change_state ( gcb, unknown ); add_char_data(gcb,2,addr('PG')); buffer_cleanup ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure hpgl_cursor ( gcb : graphics_control_block_ptr ); begin with gcb^,hpgl_device_rec_ptr(dev_dep_stuff)^ , ascii_buffer_ptr(gcb^.device_buf)^do begin try change_state ( gcb, unknown ); add_char_data ( gcb, 5, addr('PU;PA')); add_parm_data ( gcb, info1); add_char_data ( gcb, 1, addr(', ')); add_parm_data ( gcb, info2); current_cursor_state := info3; hpgl_flush_buffer ( gcb ); recover begin {modified to pass all escapes SFB 4/23/85} current := 0; escape(escapecode); end; end; end; procedure gle_init_hpgl_output ( gcb : graphics_control_block_ptr); var saved_timeout : integer; i : gle_shortint; begin with gcb^, hpgl_device_rec_ptr(dev_dep_stuff)^, ascii_buffer_ptr(device_buf)^ do try current := 0; maximum := max_buffer; driver_state := start_of_buffer; unclipped_move := hpgl_move; unclipped_draw := hpgl_draw; move := gle_soft_clip_move; draw := gle_soft_clip_draw; clear  := hpgl_clear; text := gle_soft_text {hpgl_text}; char_size := gle_soft_char_size; clip_limits := gle_soft_clip_limits; text_spacing := gle_soft_text_spacing; linestyle := hpgl_linestyle; text_dir := gle_soft_text_dir; text_just := gle_soft_text_just; marker := gle_soft_marker; marker_size := gle_soft_marker_size; set_marker := gle_soft_set_marker; index_color := hpgl_set_color; inq_p1p2 := hpgl_get_p1p2; get_polygon_info := dummy; graphics_on_off := dummy; cursor := hpgl_cursor; calc_soft_text_xform := gle_text_xform; buffer_mode := hpgl_buffer_mode; output_escapeo := hpgl_output_escapeo; output_escapei := hpgl_output_escapei; define_drawing_mode := dummy; define_color_map := dummy; polygon  := dummy; fill_index_color := dummy; linewidth := dummy; gload := dummy; gstore := dummy; get_raster := dummy; get_color_map := dummy; await_blanking := dummy; flush_buffer := hpgl_flush_buffer; soft_font_ptr := addr(font); error_return := 0; if spooling = 0 then try call (io_inq_timeout, iocb, saved_timeout ); call (io_set_timeout, iocb, 500 { ms } ); { send command that all HPGL plotters can respond to } { if the command fails then the address does not match } { the device. } add_char_data ( gcb, 2, addr('OE') ); hpgl_flush_buffer ( gcb );  call (io_read, iocb, device_buf); current := 0; { if this point is reached then a vaild HPGL device was found } try { perform an output identify seq. Note a 9872A will fail } add_char_data ( gcb, 2, addr('OI') ); hpgl_flush_buffe r ( gcb ); call (io_read, iocb, device_buf); for i := 1 to current do display_name[i] := data[i]; for i := current+1 to 6 do display_name[i] := ' '; display_name_char_count := current; current := 0; recover if escapecode = -26 { io system } then begin display_name := '9872A '; display_name_char_count := 5; current := 0; end else if escapecode = -20 {stop key} then begin current := 0; escape(-20); end else escape(escapecode); recover if escapecode = -26 then error_return := 1 else if escapecode = -20 {stop key} then begin current := 0; escape(-20); end else escape(escapecode); { ignor io errors } call (io_set_timeout, iocb, saved_timeout ); if error_return = 0 then begin add_char_data ( gcb, 12, addr('DF;SP1;IM30;') ); hpgl_flush_buffer ( gcb ); if gle_match(4,addr(display_name),4,addr('9111')) then { 9111 is input only } escape(-26) { force io error } else if gle_match(display_name_char_count,addr(display_name),5,addr('7470A')) or gle_match(display_name_char_count,addr(display_name),4,addr('7470')) then begin pallette := 2; cont_linestyles := 8; vect_linestyles := 0; end  else if gle_match(display_name_char_count,addr(display_name),5,addr('7440A')) or gle_match(display_name_char_count,addr(display_name),4,addr('7440')) then begin pallette := 8; cont_linestyles := 8; vect_linestyles := 0; end else if gle_match(display_name_char_count,addr(display_name),5,addr('7475A')) or gle_match(display_name_char_count,addr(display_name),4,addr('7475')) or gle_match(display_name_char_count,addr(display_name),4,addr('7090')) then  begin pallette := 6; cont_linestyles := 8; vect_linestyles := 0; end else {BUG FIXES FOR LENGTHS SFB 4/85} if (gle_match(display_name_char_count,addr(display_name),5,addr('7580A'))) or {SFB 9/18/86} (gle_match(display_name_char_count,addr(display_name),5,addr('7570A'))) or {SFB 9/18/86} (gle_match(display_name_char_count,addr(display_name),4,addr('7570'))) or {SFB 11/14/88}(gle_match(display_name_char_count,addr(display_name),5,addr('7575A'))) or {SFB 11/14/88}(gle_match(display_name_char_count,addr(display_name),4,addr('7575'))) or {SFB 11/14/88}(gle_match(display_name_char_count,addr(display_name),5,addr('7576A'))) or {SFB 11/14/88}(gle_match(display_name_char_count,addr(display_name),4,addr('7576'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7580B'))) or (gle_match(display_name_char_count,addr(display_name),4,addr('7580'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7585A'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7595A'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7585B'))) or (gle_match(display_name_char_count,addr(display_name),4,addr('7585'))) or (gle_match(display_name_char_count,addr(display_name),4,addr('7595'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7586B'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7596A'))) or (gle_match(display_name_char_count,addr(display_name),4{SFB},addr('7586'))) or (gle_match(display_name_char_count,addr(display_name),4{SFB},addr('7596'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('7550A'))) or (gle_match(display_name_char_count,addr(display_name),4{SFB},addr('7550'))) then begin pallette := 8; cont_linestyles := 8; vect_linestyles := 8; end else begin if (gle_match(display_name_char_count,addr(display_name),5,addr('9872A'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('9872B'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('9872S'))) or (gle_match(display_name_char_count,addr(display_name),4,addr('9872'))) then pallette := 4 else  if (gle_match(display_name_char_count,addr(display_name),5,addr('9872C'))) or (gle_match(display_name_char_count,addr(display_name),5,addr('9872T'))) then pallette := 8 else if spooling = 0 then pallette := 4 { assume 9872 like device }  else escape(-26); { can't init device, force io error } cont_linestyles := 8; vect_linestyles := 0; end; hpgl_get_hard_clip ( gcb ); display_min_x := info1; display_min_y := info3; display_max_x := info2; display_max_y := info4; gle_soft_clip_limits ( gcb ); { set default clipping limits } gamut := pallette; polygon_support := 0; { polygon routine dummyed out } display_handler_name := 'HPGL '; display_handler_char_count := 4; display_res_x := 40; display_res_y := 40; linewidths := 1; char_sizes := -1; background := 0; complement_support := 0; non_dominant_support := 0; erase_support := 0; color_map_support := 0; redef_background := 0; polygon_fill_factor := 16; polygon_solid_fill := 5; dither_support := 0; current_pos_x := 0; current_pos_y := 0; current_cursor_state := 0; { off } current_buffer_mode := 0; { imed visb } end; recover begin if escapecode = -26 then error_return := 1 else if escapecode = -20 {stop key} then begin current := 0; escape(-20); end else escape(escapecode); { ignor io errors } end; end; end. { hpgl_output } $TABLES$ $LIST OFF$ { } { Graphics Low End } { } { Module = GLE_HPIB } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide IO routines for ascii device handlers. } { Rev history } { Created - 10-10-82  } { Modified - 12-12-83 BDS -- Brought needed general_1 and hpib_1 } { routines in-line. } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  } $SEARCH 'GLE_TYPES', 'GLE_UTLS'$ $modcal$ $ALLOW_PACKED ON$ { JWS 4/10/85 } $include 'OPTIONS'$ { ******************* COMPILER OPTIONS *************** } $LINENUM 10000$ module gle_hpib_io; import gle_types, general_0,  iocomasm; export type hpib_iocb_ptr = ^ hpib_iocb; hpib_iocb = record device_addr : anyptr; name_size : gle_shortint; address : integer; select_code : integer; error : integer; end; timeoutrec = record  {tttt JS 8/3/83} counter: integer; {tttt JS 8/3/83} firsttime: boolean; {tttt JS 8/3/83} end; {tttt JS 8/3/83} procedure hpib_init ( anyvar iocb_ptr : anyptr ); procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer ); procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer ); procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr ); procedure hpib_read ( anyvar iocb_ptr, data_ptr : anyptr );  procedure hpib_term ( anyvar iocb_ptr : anyptr ); implement import iodeclarations, {general_1,} {hpib_1,} gle_utls; { The following types must match types declared in GLE_HPGL, and GLE_HPGLI } type ascii_buffer_ptr = ^ascii_buffer; ascii_buffer = packed record maximum : integer; current : integer; data : packed array [1..32767] of char; end; {||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||} {*** general_1 ***} {The following procedures have been brought in-line to avoid importing general_1 and hpib_1. NOTE: These routines must be duplicates of those found in general_1 and hpib_1 and therefore must reflect any modifications to those modules.  } FUNCTION timerexists: boolean; external; { tttt JS 8/3/83 } FUNCTION timed_out(var rec: timeoutrec): boolean; external; {tttt JS 8/3/83} PROCEDURE ioreset ( select_code : type_isc); BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_init, io_tmp_ptr); END; { of ioreset } PROCEDURE writechar ( select_code : type_isc ; value : CHAR ); BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_wtb, io_tmp_ptr, value); END; { of writechar } PROCEDURE set_timeout ( select_code : type_isc ; time : REAL { in seconds } ); BEGIN IF time>8191 { 4 byte timeout - 1 byte left for shifts } THEN BEGIN { error } io_escape(ioe_bad_tmo,select_code); END; { of IF } IF (time>0) AND (time<0.001) THEN BEGIN { error } io_escape(ioe_bad_tmo,select_code); END; { of IF } WITH isc_table[select_code] DO BEGIN { the table entry used by drivers is in milliseconds } user_time:=ROUND(time*1000); IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout := user_time; END; { of WITH DO BEGIN } END; { of set_timeout } {*** hpib_1 ***} PROCEDURE send_command( select_code : type_isc ; command : CHAR ); BEGIN WITH isc_table[select_code] DO CALL ( io_drv_ptr^.iod_send, io_tmp_ptr, command); END; { of send_command } FUNCTION my_address ( select_code : type_isc) : type_hpib_addr ; BEGIN IF isc_table[select_code].io_tmp_ptr <> NIL THEN BEGIN WITH isc_table[select_code].io_tmp_ptr^ DO IF addressed <> -1 THEN BEGIN my_address:=addressed; END ELSE BEGIN { error } io_escape(ioe_not_hpib,select_code); END; { of IF addressed } END ELSE BEGIN { error } io_escape(ioe_not_hpib,select_code); END; { of IF io_tmp_ptr } END; { of my_address } FUNCTION active_controller ( select_code : type_isc) : BOOLEAN; BEGIN IF isc_table[select_code].card_type=hpib_card THEN BEGIN active_controller:=bit_set(iostatus(select_code,3),6); END ELSE BEGIN active_controller := TRUE; END; { of IF } END; { of active_controller } {************************* this function is not used ********************} {FUNCTION system_controller ( select_code : type_isc) : BOOLEAN; BEGIN IF isc_table[select_code].card_type=hpib_card THEN BEGIN system_controller:=bit_set(iostatus(select_code,3),7); END ELSE BEGIN system_controller := TRUE; END; of IF END; of system_controller } {************************** this functio is not used *******************} {FUNCTION end_set ( select_code : type_isc ) : BOOLEAN ; VAR mybool : BOOLEAN; BEGIN WITH isc_table[select_code] DO CALL ( io_drv_ptr^.iod_end, io_tmp_ptr, mybool); end_set := mybool; END; of send_command } $PAGE$ FUNCTION addr_to_talk( device : type_device) : type_isc; VAR io_isc : type_isc; timer : INTEGER; hpibrec: timeoutrec; {tttt JS 8/3/83} BEGIN IF device>iomaxisc THEN BEGIN io_isc:=device DIV 100; WITH isc_table[io_isc] DO BEGIN IF io_tmp_ptr <> NIL THEN BEG IN { set up user timeout - in case system drivers changed it } io_tmp_ptr^.timeout:=user_time; IF io_tmp_ptr^.addressed <> -1 THEN BEGIN IF ( card_type <> hpib_card ) AND ( device MOD 100 > 31 ) THEN io_escape(ioe_misc,io_isc); send_command(io_isc,CHR(talk_constant+(device MOD 100))); send_command(io_isc,'?'); send_command(io_isc,CHR(my_address(io_isc)+listen_constant)); END ELSE BEGIN { error } io_escape(ioe_not_hpib,io_isc); END; { of IF } END ELSE BEGIN END; { of IF } END; { of WITH DO BEGIN } END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up user timeout - in case system drivers changed it } IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN { if non controller wait until listener } IF user_time = 0 THEN BEGIN REPEAT { wait forever } UNTIL bit_set(iostatus(io_isc,6),10); END ELSE BEGIN { wait for timeout value } IF timerexists THEN BEGIN {tttt JS 8/3/83} hpibrec.firsttime:=true; {tttt JS 8/3/83} hpibrec.counter:=user_time; {tttt JS 8/3/83} REPEAT {tttt JS 8/3/83} UNTIL timed_out(hpibrec) OR {tttt JS 8/3/83} bit_set(iostatus(io_isc,6),10); {tttt JS 8/3/83} END {tttt JS 8/3/83} ELSE BEGIN {tttt JS 8/3/83} timer:=user_time*3; REPEAT timer:=timer-1; UNTIL ( timer = 0 ) OR ( bit_set(iostatus(io_isc,6),10) ) ; END; {tttt JS 8/3/83} IF NOT bit_set(iostatus(io_isc,6),10) THEN io_escape(ioe_timeout,io_isc); END; { of IF user_time=0 } END; { of IF } END; { of IF card_type = hpib_card } END; { of WITH DO BEGIN } END; { of IF } addr_to_talk:=io_isc; { return select code } END; { of addr_to_talk } $PAGE$ FUNCTION addr_to_listen ( device : type_device) : type_isc; VAR io_isc : type_isc; timer : INTEGER; hpibrec: timeoutrec; {tttt JS 8/3/83} BEGIN  IF device>iomaxisc THEN BEGIN io_isc:=device DIV 100; WITH isc_table[io_isc] DO BEGIN IF io_tmp_ptr <> NIL THEN BEGIN { set up user timeout - in case system drivers changed it } io_tmp_ptr^.timeout:=user_time; IF io_tmp_ptr^.addressed <> -1 THEN BEGIN IF ( card_type <> hpib_card ) AND ( device MOD 100 > 31 ) THEN io_escape(ioe_misc,io_isc); send_command(io_isc,CHR(my_address(io_isc)+talk_constant)); send_command(io_isc,'?'); send_command(io_isc,CHR(listen_constant+(device MOD 100))); END ELSE BEGIN { error } io_escape(ioe_not_hpib,io_isc); END; { of IF } END ELSE BEGIN END; { of IF } END; { of WITH DO BEGIN } END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up user timeout - in case system drivers changed it } IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN  { if non controller wait until talker } IF user_time = 0 THEN BEGIN REPEAT { wait forever } UNTIL bit_set(iostatus(io_isc,6),9); END ELSE BEGIN { wait for timeout value } IF timerexists THEN BEGIN  {tttt JS 8/3/83} hpibrec.firsttime:=true; {tttt JS 8/3/83} hpibrec.counter:=user_time; {tttt JS 8/3/83} REPEAT {tttt JS 8/3/83} UNTIL timed_out(hpibrec) OR {tttt JS 8/3/83}  bit_set(iostatus(io_isc,6), 9); {tttt JS 8/3/83} END {tttt JS 8/3/83} ELSE BEGIN {tttt JS 8/3/83} timer:=user_time*3; REPEAT timer:=timer-1; UNTIL ( timer  = 0 ) OR ( bit_set(iostatus(io_isc,6),9) ) ; END; {tttt JS 8/3/83} IF NOT bit_set(iostatus(io_isc,6),9) THEN io_escape(ioe_timeout,io_isc); END; { of IF user_time=0 } END; { of IF }  END; { of IF card_type = hpib_card } END; { of WITH DO BEGIN } END; { of IF } addr_to_listen:=io_isc; END; { of addr_to_listen } $PAGE$ { set to talk exists because of HPIB_2/HPIB_3 - those routines are intended to be the controller ( active ) and should not wait for the card to be addressed as talker. addr_to_talk is used by data transfer routines. set_to_talk is used by bus control routines. } {************************ this function is never used ******************} {FUNCTION set_to_talk ( device : type_device) : type_isc; VAR io_isc : type_isc; BEGIN IF device>iomaxisc THEN BEGIN io_isc:=addr_to_talk(device); END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN set up user timeout - in case system drivers changed it IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN  io_escape(ioe_not_act,io_isc); END; of IF END; of IF card_type = hpib_card END; of WITH DO BEGIN END; of IF set_to_talk:=io_isc; return select code END; of set_to_talk } $PAGE$ { set to listen exists because of HPIB_2/HPIB_3 - those routines are intended to be the controller ( active ) and should not wait for the card to be addressed as listener. addr_to_listen is used by data transfer routines. set_to_listen is used by bus control routines.  } {******************* this function is never used **********************} {FUNCTION set_to_listen ( device : type_device) : type_isc; VAR io_isc : type_isc; timer : INTEGER; BEGIN IF device>iomaxisc THEN BEGIN io_isc:=addr_to_listen(device); END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN set up user timeout - in case system drivers changed it IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN io_escape(ioe_not_act,io_isc); END; of IF END; of IF card_type = hpib_card END; of WITH DO BEGIN END; of IF set_to_listen:=io_isc; END; of set_to_listen } {||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||} procedure hpib_inq_timeout ( anyvar iocb_ptr : anyptr; var value : integer ); begin with hpib_iocb_ptr(iocb_ptr)^ do begin value := isc_table[select_code].user_time; end; end; procedure hpib_set_timeout ( anyvar iocb_ptr : anyptr; value : integer ); begin with hpib_iocb_ptr(iocb_ptr)^ do set_timeout (select_code,value/1000); end; procedure hpib_init ( anyvar iocb_ptr : anyptr ); var cnt : gle_shortint; begin with hpib_iocb_ptr(iocb_ptr)^ do begin error := 1; try address := gle_read_integer ( name_size, device_addr, cnt ); select_code := address div 100; if (select_code >= minrealisc) and (select_code <= maxrealisc) then begin ioreset (select_code); error := 0; end; recover { error is set, ignore range and io escapes } if (escapecode <> -8) and (escapecode <> -26) then escape(escapecode); end; end; procedure hpib_write ( anyvar iocb_ptr, data_ptr : anyptr ); var i : integer; io_isc : type_isc; begin with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do begin io_isc := addr_to_listen(address); with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do begin for i := 1 to current do call (iod_wtb, io_tmp_ptr, data[i] ); writechar(io_isc,io_carriage_rtn); writechar(io_isc,io_line_feed); end; current := 0; end; end; procedure hpib_read ( anyvar iocb_ptr, data  _ptr : anyptr ); var i : integer; io_isc : type_isc; begin with hpib_iocb_ptr(iocb_ptr)^,ascii_buffer_ptr(data_ptr)^ do begin io_isc := addr_to_talk ( address ); with isc_table[io_isc].io_drv_ptr^, isc_table[io_isc] do begin i := 0; repeat i := i + 1; call (iod_rdb, io_tmp_ptr, data[i]); until ( ( i >= maximum ) or ( data[i] = io_line_feed ) ); if data[i] = io_line_feed then i := i - 1; if i <> 0 then if data[i] = io_carriage_rtn then i := i - 1; current := i; end; end; end; procedure hpib_term ( anyvar iocb_ptr : anyptr ); begin end; end. { of module gle_hpib_io } $LIST ON$ $TABLES$ $LIST OFF$ { } { Graphics Low End } { } { Module = GLE_KNOB_IN } { Programer = BJS } { Date = 11-05-82 } {  } { Purpose: To provide a device handler for the knob input device. } { Rev history } { Created - 11- 5-82  } { Modified - 4-11-84 BY JWS -- remove unitio dependecies } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $UCSD$ $SEARCH 'GLE_TYPES','GLE_UTLS'$ $modcal$ $INCLUDE 'OPTIONS'$ { ***************** COMPILER OPTIONS **************** } $LINENUM 18000$ module gle_knob_in; import gle_types; export type knob_device_rec_ptr = ^knob_device_rec; knob_device_rec = packed record knob_type : gle_shortint; { 0 - unknown device } { 1 - 9816 } { 2 - 9826 } { 3 - 9836 } { 4 - 9836c } { 5 - NOT SUPPORTED (98627A)} { 6 - 9837A } { 7 - GATORBOX } { 8 - BOBCAT (HIRES) } { 9 - BOBCAT_LORES } echo_rate : gle_shortint; echo_mult : gle_shortint; last_but : integer; digitize_enabled : boolean; last_x : integer; last_y : integer; end; procedure gle_init_knob_input ( gcbi : graphics_input_control_block_ptr ); implement import gle_utls,sysglobals; procedure eot(fp: fibp); begin end; {do nothing} procedure openfib(anyvar F: fib; unum: unitnum); begin if (unum<=0) or (unum>maxunit) then ioresult := ord(ibadunit) else with F do begin fistextvar := false; funit := unum; feot := eot; call(unitable^[unum].dam, f, unum, openunit); end; end; procedure gunitread ( u: integer; buf: charptr; len: integer); var f: file; r: amrequesttype; begin with unitable^[u] do begin openfib(f, u); if ioresult = ord(inoerror) then begin r := readbytes; call(tm, addr(f), r, buf^, len, 0); end; end; end; function gunitbusy ( u: integer): boolean; var f: file; begin with unitable^[u] do begin gunitbusy := true; openfib(f, u); if ioresult = ord(inoerror) then begin call(tm, addr(f), unitstatus, f, 0, 0); gunitbusy := fibp(addr(f))^.fbusy; end; end; end; procedure knob_dummy ( gcbi : graphics_inpu  t_control_block_ptr ); begin end; procedure knob_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^,knob_device_rec_ptr(dev_dep_stuff)^ do case knob_type of 0 : begin { input_xxxx must be set by config } info1 := input_min_x; info2 := input_max_x; info3 := input_min_y; info4 := input_max_y; end; 1,2 : begin info1 := 0; info2 := 399; info3 := 0; info4 := 299; end; 3,4 : begin info1 := 0;  info2 := 511; info3 := 0; info4 := 389; end; end; { case } end; procedure knob_sample ( gcbi : graphics_input_control_block_ptr ); var ch : char; mycharptr: charptr; x_adj, y_adj, rate : integer; commandinprogress: char;  interruptlevel: integer; begin mycharptr:=addr(ch); with gcbi^,knob_device_rec_ptr(dev_dep_stuff)^ do begin if last_but < 0 then info3 := -1 else info3 := 0; if gunitbusy(2) then { if no keys in type ahead buffer } begin { just return last position } info1 := input_cpx; info2 := input_cpy; end else begin gunitread(2,mycharptr,1); x_adj := 0; y_adj := 0; rate := 0; case ord(ch) of 8 : x_adj := -echo_rate; { left arrow } 28 : x_adj := +echo_rate; { right arrow } 10 : y_adj := -echo_rate; { down arrow } 31 : y_adj := +echo_rate; { up arrow } 49,33 : rate := 1; { number 1 } 50,64 : rate := 2; { ... 2 } 51,35 : rate := 3; 52,36 : rate := 4; 53,37 : rate := 5; 54,94 : rate := 6; 55,38 : rate := 7; 56,42 : rate := 8; 57,40 : rate := 9; { number 9 } otherwise begin if ch = chr(13) then ch := ' '; if digitize_enabled then begin if (last_but = 0) then begin last_but := -ord(ch); info3 := -1; last_x := input_cpx; last_y := input_cpy; end end else info3 := ord(ch); end; end; { of case } { ck for new rate } if rate > 0 then echo_rate := (echo_mult * (rate-1) + 1); { calc new x and y } input_cpx := gle_shortint_max(input_min_x,gle_shortint_min(input_max_x,input_cpx+x_adj)); input_cpy := gle_shortint_max(input_min_y,gle_shortint_min(input_max_y,input_cpy+y_adj)); info1 := input_cpx; info2 := input_cpy; end; end; end; procedure knob_start_digitize ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^,knob_device_rec_ptr(dev_dep_stuff)^ do begin digitize_enabled := true; echo_mult := info2; last_but := 0; end; end; procedure knob_get_digitize ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^,knob_device_rec_ptr(dev_dep_stuff)^ do begin digitize_enabled := false; info1 := last_x; info2 := last_y; info3 := abs(last_but); last_but := 0; end end; procedure knob_input_echo ( gcbi : graphics_input_control_block_ptr ); begin if gcbi^.info1 <> 0 then write(#G); end; procedure gle_init_knob_input ( gcbi : graphics_input_control_block_ptr); begin with gcbi^,knob_device_rec_ptr(dev_dep_stuff)^ do begin input_handler_name := 'KNOB '; input_handler_char_count := 4; sample := knob_sample; start_digitize := knob_start_digitize; get_digitize := knob_get_digitize; input_echo := knob_input_echo; input_escapei := knob_dummy; input_escapeo := knob_dummy; inq_p1p2 := knob_get_input_p1p2; case knob_type of 1 : begin input_name := '9816A '; input_name_char_count := 5; input_res_x := 2.375; { 168mm X 126mm } input_res_y := 2.37301587301587; end; 2 : begin input_name := '9826A ' ; input_name_char_count := 5; input_res_x := 3.325; { 120mm X 90mm } input_res_y := 3.32222222222222; end; 3 : begin input_name := '9836A '; input_name_char_count := 5; input_res_x := 2.43333333333333; { 210mm X 160mm } !  input_res_y := 2.43125; end; 4 : begin input_name := '9836C '; input_name_char_count := 5; input_res_x := 2.35483870967742; { 217mm X 163mm } input_res_y := 2.38650306748466; end; otherwise ; {98627A etc not supported} end; input_cpx := info1; { setup init input values } input_cpy := info2; last_x := info1; last_y := info2; last_but := 0; knob_get_input_p1p2 ( gcbi ); input_min_x := info1;  input_max_x := info2; input_min_y := info3; input_max_y := info4; digitize_enabled := false; echo_rate := 1; error_return := 0; end; end; end. { knob_input } $LIST ON$ { } { Graphics Low End } { } { Module = GLE_RAS_OUT } { Programer = BJS } { Date = 11-05-82 } {  } { Purpose: To provide device handler routines for raster devices. } { Rev history } { Created - 11-05-82  } { Modified - 02-14-84 BDS (added code for gator black/white) } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_TYPES', 'GLE_STEXT', 'ASM_STEXT', 'GLE_SCLIP', 'ASM_SCLIP', 'GLE_SMARK', 'GLE_AUTL', 'RGL'$ $modcal$ $TABLES OFF$ $include 'OPTIONS.'$ { ****************** COMPILER OPTIONS ********************** } $linenum 8000$ $DEBUG OFF$ module gle_ras_out; import gle_types,sysglobals,sysdevs,gle_aras_out; export  procedure gle_init_raster_output ( gcb : graphics_control_block_ptr); procedure gator_clear ( gcb : graphics_control_block_ptr ); PROCEDURE BOBCAT_CLEAR( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); type raster_byte = 0..255; raster_code_space = packed array[1..240] of raster_byte; dither_type = packed array [0..15] of raster_byte; cmap_def = packed record map_red : gle_shortint; map_grn : gle_shortint; map_blu : gle_shortint; end; system_cmap_def = packed array [0..255] of cmap_def; raster_device_rec_ptr = ^ raster_device_rec; raster_device_rec = record addr1 : anyptr ; addr2 : anyptr ; addr3 : anyptr ; n3 : gle_shortint ; devicetype  : gle_shortint ; deviceaddress : integer ; monitortype : gle_shortint ; plane1_addr : anyptr ; plane1_offset : integer ; plane2_offset : integer ; plane3_offset : integer ; n_glines  : gle_shortint ; gspacing : gle_shortint ; bytesperline : gle_shortint ; hard_xmax : gle_shortint ; hard_ymax : gle_shortint ; red_intensity : gle_shortint ; grn_intensity : gle_shortint ;  blu_intensity : gle_shortint ; dither_pattern : dither_type; cursor_x : gle_shortint ; cursor_y : gle_shortint ; area_draw_mode : gle_shortint ; pen_draw_mode : gle_shortint ; linepattern : gle_! shortint ; pen_number : gle_shortint ; cpen : gle_shortint ; oldpattern : gle_shortint ; rgltemp1 : integer ; rgltemp2 : integer ; rgltemp3 : integer ; rgltemp4 : integer ; rgltemp5 : integer ; repeatrate : gle_shortint ; repeatcount : gle_shortint ; index : integer ; softvec : raster_code_space ; system_cmap : system_cmap_def; {brightness_sequence : packed array [0..255] of gle_shortint;} {count : packed array [0..255] of gle_shortint;} cmap_address : integer; end; const packed_pixel_odd_byte_display = 0; packed_pixel_display = 1;  packed_pixel_3_plane_display = 2; byte_per_pixel_display = 3; gator_display = 4; gatorbox_display = 5; bobcat_display = 6; bobcat_lores_display = 7; catseye_display  = 8; catseye_hrx_display = 9; woodcut_vga_display = 10; woodcut_med_display = 11; woodcut_hrx_display = 12; woodcut_vgam_display = 13; { CFB - 30JUL91 } woodcut_hrxm_display = 14; { CFB - 30JUL91 } dominant = 3; erase = 0; non_dominant = 7; compliment = 10; clr_with_LM  = 128; one_with_LM = 255; implement import gle_stext, gle_astext, gle_sclip, gle_asclip, gle_smark, gle_autl; type word_array = packed array[1..maxint] of gle_shortint; fixed_word_array = array [0..13] of gle_shortint; map_array = array[1..maxint] of integer; wd_ptr = ^word_array; byte_array = packed array [0..maxint] of raster_byte; type gboxstatreg2 = packed record {gatorbox secondary status register layout} enable_vg_intr, vg_intr, enable_bm_intr, bm_busy, enable_vsync_intr, vsync_intr, not_hsync, enable_video : boolean; end; {ADDED GTCOLREG, BTCOLREG SFB 6/25/85} gboxreg = (gwreg, ghreg, grreg, gbusyreg, gwpreg, gtcolreg); gboxregtype = array[gboxreg] of gle_shortint; bobreg = (bwreg, bhreg, bwrreg, bprreg, bbusyreg, bwenreg, bsxreg, bsyreg, bdxreg, bdyreg, bmovereg, btcolreg, bfben0reg {added 2/9/88 - SFB} ); bobregtype = array[bobreg] of gle_shortint; const gboxregs = gboxregtype[hex('5001'), hex('5003'), hex('5007'), hex('0002'), hex('6009'), hex('68BD')]; bobregs = bobregtype [hex('4102'), hex('4106'), hex('40EE'), hex('40EA'), hex('4044'), hex('4090'), hex('40F2'), hex('40F6'), hex('40FA'), hex('40FE'), hex('409C'), hex('60BC'), hex('4500') {added 2/9/88 - SFB} ]; var fb_ptr : ^byte_array; fb_ptr_ptr : ^integer; topmask : gle_shortint; {used to store copy of gle_gcb^. gamut, if bobcat type display. Note--topmask should be set to 0 before accessing any topcat registers, so we know windowmover need not be tested for ready. Once we are ready to do window moves, should set topmask to gle_gcb^.gamut, so bobmoveready works!! This sequence is implemented by setup_bobcat.} {const} {init_crt = fixed_word_array [22,16,21,01,48,11,48,48,0,15,0,0,0,0 ];{17"} {init_crt = fixed_word_array [20,16,17,2,48,11,48,48,0,15,0,0,0,0 ];{19"} {init_crt = fixed_word_array [20,16,16,4,48,11,48,48,0,15,0,0,32,0 ];{17"-NEW} PROCEDURE wait_ready; BEGIN REPEAT UNTIL status^.notbusy END; PROCEDURE set_rule ( rule : INTEGER ); BEGIN replregcopy := rule; wait_ready; rule_reg^ := rule; END; PROCEDURE set_width ( width : INTEGER ); BEGIN windowregcopy := width; wait_ready; width_reg^ := width; END; {gator_fill_index_color actually prepares dither_pattern for both gator_display, and all bobcat_displays.} procedure gator_fill_index_color ( gcb : graphics_control_block_ptr ); type dpt1 = packed array [0..15] of boolean; dpt" 2 = packed array [0..16] of dpt1; var i : integer; j : integer; r : integer; g : integer; b : integer; const t = true; f = false; dp = dpt2[dpt1[f,f,f,f, f,f,f,f, f,f,f,f, f,f,f,f], dpt1[t,f,f,f, f,f,f,f, f,f,f,f, f,f,f,f], dpt1[t,f,f,f, f,f,f,f, f,f,t,f, f,f,f,f], dpt1[t,f,f,f, f,f,f,f, t,f,t,f, f,f,f,f], dpt1[t,f,t,f, f,f,f,f, t,f,t,f, f,f,f,f], dpt1[t,f,t,f, f,t,f,f, t,f,t,f, f,f,f,f], dpt1[t,f,t,f, f,t,f,f, t,f,t,f, f,f,f,t], dpt1[t,f,t,f, f,t,f,t, t,f,t,f, f,f,f,t], dpt1[t,f,t,f, f,t,f,t, t,f,t,f, f,t,f,t], dpt1[t,f,t,f, t,t,f,t, t,f,t,f, f,t,f,t], dpt1[t,f,t,f, t,t,f,t, t,f,t,f, f,t,t,t], dpt1[t,f,t,f, t,t,f,t, t,f,t,f, t,t,t,t], dpt1[t,f,t,f, t,t,t,t, t,f,t,f, t,t,t,t], dpt1[t,t,t,f, t,t,t,t, t,f,t,f, t,t,t,t], dpt1[t,t,t,f, t,t,t,t, t,f,t,t, t,t,t,t], dpt1[t,t,t,f, t,t,t,t, t,t,t,t, t,t,t,t], dpt1[t,t,t,t, t,t,t,t, t,t,t,t, t,t,t,t]]; begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin if info1 = 0 then {set up dither pattern} begin r := info2; g := info3; b := info4; current_polygon_red := r; current_polygon_green := g; current_polygon_blue := b; r := (r+32) div 64; g := (g+32) div 64; b := (b+32) div 64; red_intensity := r; grn_intensity := g; blu_intensity := b; i:=r; if i blockmover ready } end; { read any gatorbox register that requires blockmover not busy } function readgboxreg(reg : gboxreg) : gle_shortint; var regptr : ^char; begin regptr := anyptr(control_space + gboxregs[reg]); waitgboxmoveready; readgboxreg := ord(regptr^); end; { write any gatorbox register that requires blockmover not busy } procedure setgboxreg(reg : gboxreg; value : gle_shortint); var regptr : ^char; begin regptr := anyptr(control_space + gboxregs[reg]); waitgboxmoveready; regptr^ := chr(value); end; { sets gatorbox DGL area using tiler, as follows: } { if info1 =-1, info2 = 0 clear display to all 0 pixels} { if info1 =-1, info2 = n set display to all n-value pixels} { if info1 =n, info2 = 0 clear only planes with 1 bits in n, (n >= 0) note that info1 = 0 really means all planes!} { other combinations not supported} { does not save previous values of gatorbox registers used !! } procedure gatorbox_clear( gcb : graphics_control_block_ptr ); var depth : integer; savesc : integer; begin writeregcopy := 0; with gcb^ do if info1 > 0 then writeregcopy := (255-info1) mod 256; { so interrupt can restore non-readable wp register } TRY {in case STOP is hit or other error, can restore gatorbox regs} depth := 256 - (raster_device_rec_ptr(gcb^.dev_dep_stuff)^.n_glines div 4); setgbox" reg(gwpreg,writeregcopy);{ write enable all planes } setgboxreg(grreg,128+64); { set replacement rule to rule 0, tile down } setgboxreg(ghreg,depth); { set height to tiles for n_glines } setgboxreg(gwreg,0); { set width to 256 tiles } waitgboxmoveready; fb_ptr^[0] := fb_ptr^[0]; { start the tiler move } with gcb^ do if info2 <> 0 then begin setgboxreg(grreg,128+64+15); { set replacement rule to rule 15, tile down } writeregcopy := 255-info2; { protect only planes 0 in info2 } setgboxreg(gwpreg, writeregcopy); waitgboxmoveready; fb_ptr^[0] := fb_ptr^[0]; end; writeregcopy := 0; setgboxreg(gwpreg,0); { write enable all planes } setgboxreg(grreg,3); { set replacement rule to "idle"--no tile, dominant } RECOVER {restore gatorbox registers to "idle" state before exiting, if some kind of escape} begin try savesc := escapecode; writeregcopy := 0; setgboxreg(gwpreg,0); setgboxreg(grreg,3); recover; escape(savesc); end; end; { wait for bobcat windowmover to go ready } procedure waitbobmoveready; var regptr : ^gle_shortint; temp : gle_shortint; begin if topmask <> 0 then {while topmask still 0, not doing any ops requiring wait} begin regptr := anyptr(control_space + bobregs[bbusyreg]); repeat {do it slowly, so as not to interrupt topcats too much} temp := regptr^; temp := gle_iand(temp,256*topmask); temp := gle_ishift(temp,-8); until temp = 0; end; end; { read any bobcat register (may require windowmover not busy) } function readbobreg(reg : bobreg) : integer; var regptr : ^gle_shortint; begin regptr := anyptr(control_space + bobregs[reg]); waitbobmoveready; readbobreg := regptr^; end; { write any bobcat register (may require windowmover not busy) } procedure setbobreg(reg : bobreg; value : integer); var regptr : ^gle_shortint; begin regptr := anyptr(control_space + bobregs[reg]); waitbobmoveready; regptr^ := gle_iand(value, hex('ffff')); end; { sets Bobcat DGL area using windowmover, as follows: } { if info1 =-1, info2 = 0 clear display to all 0 pixels} { if info1 =-1, info2 = n set display to all n-value pixels} { if info1 =n, info2 = 0 clear only planes with 1 bits in n, (n >= 0) note that info1 = 0 really means all planes!} { other combinations not supported} { does not save previous values of bobcat registers used !! } procedure bobcat_clear( gcb : graphics_control_block_ptr ); var planes_to_clear : gle_shortint; savesc : integer; begin TRY {in case STOP is hit or other error, can restore bobcat regs} with gcb^ do if info1 <> 0 then {write enable appropriate planes} planes_to_clear := info1 MOD (gamut+1) else planes_to_clear := gamut; setbobreg(bwrreg,0); { set window replacement rule to rule 0} setbobreg(bwreg,romval(13)); { set width to visible display width } { Below is bugfix for the "clear typeahead pixels" bug SFB 9-27-86 } { setbobreg(bhreg,romval(17)); { set height to visible display height } setbobreg(bhreg,raster_device_rec_ptr(gcb^.dev_dep_stuff)^.n_glines); setbobreg(bsxreg,0); { set window source x reg to 0 } setbobreg(bsyreg,0); { set window source y reg to 0 } setbobreg(bdxreg,0); { set window destination x reg to 0 } setbobreg(bdyreg,0); { set window destination y reg to 0 } setbobreg(bfben0reg,planes_to_clear*256); {added for CATSEYE due to difference from Topcat - SFB 2/9/88 } setbobreg(bmovereg,planes_to_clear*256); { trigger window move } {below is bugfix for mono display clear_display SFB 9/16/86} with gcb^ do if info2 <> 0 then {we're asked to setframe buffer to value info2} begin setbobreg(bwrreg, 15); { write 1s} setbobreg(bfben0reg,info2*256); {added for CATSEYE due to difference from Topcat - SFB 2/9/88 } setbobreg(bmovereg, info2*256); { trigger window move } end; setbobreg(bwrreg,3); { # restore window replacement rule to rule 3 } RECOVER {restore bobcat registers to "idle" state before exiting, if some kind of escape} begin try savesc := escapecode; setbobreg(bwrreg,3); setbobreg(bwenreg,hex('ff')); recover; escape(savesc); end; end; procedure setup_gator(gcb : graphics_control_block_ptr); var color_list : packed array [0..47] of gle_shortint; i : integer; begin set_6845s (gcb); status^.bit0 := write_to_status; i := 0; with gcb^ do begin info1 := 0; info2 := 1; info_ptr1 := addr(color_list); call (define_color_map,gcb); end; set_rule(dominant); end; procedure setup_gatorbox(gcb : graphics_control_block_ptr); const blinkrega = hex('6001'); blinkregb = hex('6005'); type aptrtype = ^anyptr; var ptr : ^char; begin {NOTE - cannot guarantee access to frame buffer will not cause DTACK error until set_6845s has executed ! Normally would set gamut in rgcbinit, but due to need to run rgcbinit BEFORE set_6845s, kluge it here.} set_6845s (gcb); { next compute gamut by seeing which frame buffer planes are loaded } setgboxreg(grreg,dominant); {tiler off, dominant} writeregcopy := 0; setgboxreg(gwpreg,0); {write enable all planes} {set ptr to point to last location in framebuffer} with raster_device_rec_ptr(gcb^.dev_dep_stuff)^ do begin {added setup of monitortype SFB 6/11/85} monitortype := gcb^.info4; if monitortype = 0 then {SFB 6/25/85} setgboxreg(gtcolreg,0); ptr := anyptr(integer(aptrtype(plane1_addr)^) + 1024*1024 - 1); end; ptr^ := #255; {write 1s to 8 potential planes} gcb^.gamut := ord(ptr^); {unloaded planes return 0s - planes MUST be loaded in sequence from plane 0 to plane n (n<=7) } with gcb^ do begin ptr := anyptr(info2+blinkrega); {now enable blink registers} ptr^:= chr(gamut); {could not do before because we did} ptr := anyptr(info2+blinkregb); {know which planes to enable--gamut} ptr^:= chr(gamut); {now contains this info} end; end; {leaving 8 planes write enabled} procedure setup_bobcat(gcb : graphics_control_block_ptr); const planemask = hex('60ba'); nblank = hex('4080'); type aptrtype = ^anyptr; planes_mask_type = packed array[1..8] of char; const planes_mask = planes_mask_type[#1, #3, #7, #15, #31, #63, #127, #255]; var cptr: ^char; ptr : ^gle_shortint; w,h : gle_shortint; numplanes : integer; begin topmask := 0; {until topmask < > 0, DO NOT do bobcat operations which require wait on windowmover!!} {NOTE - cannot guarantee access to frame buffer will not cause DTACK error until set_6845s has executed ! Normally would set gamut in rgcbinit, but due to need to run rgcbinit BEFORE set_6845s, kluge it here.} {Following test added to prevent traversal of graphics "ID" ROM for CATSEYEs. This is needed to support the "suppress display clear" value (bit 7) of the control word in display_init... We trust that either we are not running CATSEYE (hence the test) in which case set_6845s is called and doesn't clear, or that the BOOTROM has traversed the ID ROM at boot time. Rev C and later BOOTROMs guarantee to do this, and CATSEYE is not supported on earlier BOOTROMs except for LCC in 310/320. On 310/320, the display will have been initialized because LCC (any CATSEYE actually) can only reside at $560000 in DIO I space, and all bitmap-capable BOOTROMs initialize with the ID ROM for this select code. CATSEYE can only be address-switched in DIO II space, which is not supported on SPUs with pre-rev C BOOTROMs. SFB} with gcb^ do if (info1<>mcatseye) and (info1<>mcatseye_hrx) then {SFB} set_6845s (gcb); setbobreg(bprreg,dominant*256); {pixel replacement rule dominant (in MSB)} setbobreg(bwenreg,-256 {hex('ff00')} ); {write enable all planes} {now find gamut == plane mask == number of planes loaded} with gcb^, raster_device_rec_ptr(dev_dep_stuff)^ do begin cp# tr := anyptr(info2 + hex('5b')); if cptr^ <> #0 then {ID location $5b contains number of planes} gamut := ord(planes_mask[ord(cptr^)]) else begin {have to sort out for ourselves which planes are loaded} { compute gamut by seeing which frame buffer planes are loaded } w := romval(hex('5')); {find frame buffer width, height} h := romval(hex('9')); {set ptr to point to last location in framebuffer--it's offscreen} cptr := anyptr(integer(aptrtype(plane1_addr)^) + w*h - 1); cptr^ := #255; {write 1s to 8 potential planes} gamut := ord(cptr^); {unloaded planes return 0s - planes MUST be loaded in sequence from plane 0 to plane n (n<=7) } end; ptr := anyptr(info2+nblank); {enable NBLANK register} ptr^:= 256*gamut; if color_map_support <> 0 then begin setbobreg(btcolreg, 0); {SFB 7/10/85} ptr := anyptr(info2+planemask); {now enable cmap planemask register} ptr^:= gamut; end; topmask := gamut; {now can do windowmover operations, as we know gamut} end; end; procedure setup_woodcut(gcb : graphics_control_block_ptr); {CFB 12JUN91} const planemask = hex('6061A'); {lower two bytes} type aptrtype = ^anyptr; planes_mask_type = packed array[1..8] of char; const planes_mask = planes_mask_type[#1, #3, #7, #15, #31, #63, #127, #255]; var cptr : ^char; ptr : ^gle_shortint; w,h : gle_shortint; numplanes : integer; begin {now find gamut == plane mask == number of planes loaded} with gcb^, raster_device_rec_ptr(dev_dep_stuff)^ do begin cptr := anyptr(info2 + hex('5b')); gamut := ord(planes_mask[ord(cptr^)]); if color_map_support <> 0 then begin ptr := anyptr(info2+planemask); {now enable cmap planemask register} ptr^:= gamut*256+gamut; end; topmask := gamut; end; end; procedure bobcat_fill_index_color( gcb : graphics_control_block_ptr ); label 1; type aptrtype = ^anyptr; four_row_array = packed array[0..3,0..1023] of char; var move_width, first_fill_row, i,nmoves : gle_shortint; fill_area : ^four_row_array; begin { SFB 2-27-85 } with gcb^, raster_device_rec_ptr(dev_dep_stuff)^ do begin if gamut<>1 then rfill_index_color( gcb ) {set up dither_pattern with fill pattern} else gator_fill_index_color( gcb ); if (devicetype = catseye_display) or (devicetype = catseye_hrx_display) then begin dither_to_pattregs( gcb ); goto 1; end; {will use TRR, not offscreen Framebuf to hold area fill pattern. See rfill_index_color in RGL - SFB 2/9/88} {now get pointer to last four pixel rows on screen, by using rgl info on start of frame buffer and ID ROM info on height of frame buffer} first_fill_row := romval(9) - 4; {fourth last framebuf row} fill_area := anyptr(integer(aptrtype(plane1_addr)^) + first_fill_row*1024); setbobreg(bwenreg, 256*gamut); setbobreg(bprreg, 256*3); if devicetype = bobcat_display then begin for i:=0 to 15 do {copy dither_pattern to offscreen area at left edge} fill_area^[i div 4, i mod 4] := chr(dither_pattern[i]); nmoves := 7; move_width := 4;  end; if devicetype = bobcat_lores_display then begin for i:=0 to 15 do {copy dither_pattern to offscreen area at left edge} begin fill_area^[i div 4, (i mod 4)*2 ] := chr(dither_pattern[i]); fill_area^[i div 4, (i mod 4)*2 + 1] := chr(dither_pattern[i]); end; nmoves := 6; move_width := 8; end; {now use window mover to replicate fill cell across full width of frame buf} setbobreg(bhreg, 4); setbobreg(bsxreg, 0); setbobreg(bsyreg, first_fill_row); setbobreg(bdyreg, first_fill_row); setbobreg(bwrreg, 3); for i := 0 to nmoves do begin setbobreg(bwreg, move_width); setbobreg(bdxreg, move_width); {destination x always = width because it's a geometric sequence with r=2} setbob$ reg(bmovereg, 256*gamut); {do the move} move_width := move_width * 2; {move twice as many next time} end; end; {with} 1:end; procedure rdummy_proc ( gcb : graphics_control_block_ptr ); begin end; procedure rget_polygon_info ( gcb : graphics_control_block_ptr ); begin { only solid fill supported } with gcb^ do if info2 = polygon_solid_fill then error_return := 0 else error_return := 1; end; procedure rdefine_color_map ( gcb : graphics_control_block_ptr ); type packed_color_map_def = packed array [0..15] of gle_shortint; color_map_ptr = ^packed_color_map_def; color_data_def = packed array [0..3*256-1 {47}] of gle_shortint; color_data_ptr_def = ^color_data_def; var color_map : color_map_ptr; temp_color_map : packed_color_map_def; n,i : gle_shortint; temp : integer; brt : array [0..255 {15}] of integer; color_data_ptr : color_data_ptr_def; packed_map : boolean; begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin packed_map := true; if (display_name = '98700A') {gbox or any bobcat SFB 6/11/85} or (display_name = '98542A') or (display_name = '98543A') or (display_name = '98544A') or (display_name = '98545A') or (display_name = '98547A') or (display_name = '98548A') {SFB} or (display_name = '98549A') or (display_name = '98550A') {SFB} or (display_name = 'E640 ') or (display_name = 'E1024 ') {CFB 30JUL91} or (display_name = 'E1280 ') or (display_name = 'E640G ') {CFB 30JUL91} or (display_name = 'E1280G') then {CFB 30JUL91} packed_map := false; color_data_ptr := info_ptr1; for i := info1 to info2 do with system_cmap[i] do begin n := (i - info1)*3; map_red := color_data_ptr^[n]; map_grn := color_data_ptr^[n+1]; map_blu := color_data_ptr^[n+2]; if packed_map then temp_color_map[i] := (15-map_red div 64)*256 + (15-map_grn div 64) * 16 + (15-map_blu div 64);  end; if color_map_support = yes then begin color_map := anyptr(cmap_address); if packed_map then begin rawait_blanking(gcb); for i := info1 to info2 do color_map^[i] := temp_color_map[i]; end else { unpacked map } for i:= info1 to info2 do with system_cmap[i] do begin info2 := map_red div 4; info3 := map_grn div 4; info4 := map_blu div 4; if display_name = '98700A' then begin {GATORBOX} info1 := i; if monitortype = 3 then {discrete colormap SFB 6/11/85} setgboxcmap(gcb) else set_nereid(gcb); {SFB 6/11/85} end else { WOODCUT support CFB 12JUN91 } if (display_name = 'E640 ') or (display_name = 'E1024 ') or (display_name = 'E1280 ') or (display_name = 'E640G ') or (display_name = 'E1280G') then begin info1 := i; set_wood_cmap(gcb); end else begin {BOBCAT} info1 := 255-i; set_nereid(gcb); end; end; end; {We now calculate brightness sequence on the fly in RGL, when setting up to fill a polygon. The reason to do this is that, with color maps now having up to 256 elements, the sorting takes too long to do each time we change color map, so we do it only when it's relevant, during  polygon fill setup. That's why the code is no longer here.} end; end; procedure gle_init_raster_output ( gcb : graphics_control_block_ptr); var cnt : gle_shortint; tempinfo3{, tempinfo1}: integer; {SFB 9/09/86} begin with gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do begin tempinfo3 := info3; {KLUGE TO ALLOW EXPANSION OF COLORMAP DISPLAY - SFB} {tempinfo1 := info1; if info1 = mcatseye then {fake it for rgcbinit SFB 9/09/86 info1 := mbobcat;} {removed as rgcbinit is fixed - SFB 2/9/88} if (info1 = mgatorbox) then begin fb_ptr_ptr := info_ptr1; fb_ptr := anyptr(fb_ptr_ptr^); rule_reg := anyptr(info2 + gboxregs[grreg]-1); width_reg := anyptr(info2 + gboxregs[gwreg]-1); statu$ s := anyptr(info2 + 2); { secondary gatorbox intr reg } info3 := info2 + romval(hex('33')); {RGCBINIT WANTS INFO3 = COLORMAP BASE ADDRESS} crt := nil; ww_reg := anyptr(info2 + gboxregs[gwreg]-1); end; if (info1=mbobcat) or (info1=mbobcatlores) or (info1=mcatseye {SFB}) or (info1=mcatseye_hrx {SFB}) then begin fb_ptr_ptr := info_ptr1; fb_ptr := anyptr(fb_ptr_ptr^); rule_reg := anyptr(info2 + bobregs[bprreg]); {pixel rule reg} width_reg := anyptr(info2 + bobregs[bwreg]); {window width reg} status := anyptr(info2 + bobregs[bbusyreg]); {windowmover busy reg} info3 := info2 + romval(hex('33')); {RGCBINIT WANTS INFO3 = COLORMAP BASE ADDRESS} if info2=info3 then info3 := 0;  {SET CMAP_ADDRESS TO 0 IF THERE IS NO COLORMAP} crt := nil; ww_reg := anyptr(info2 + bobregs[bwreg]); end; if (info1 = m9837a) then begin fb_ptr_ptr := info_ptr1; fb_ptr := anyptr(fb_ptr_ptr^); rule_reg := anyptr(info2 + (hex('4008'))); width_reg := anyptr(info2 + (hex('400c'))); status := anyptr(info2 + (hex('4000'))); crt := anyptr(info2 + (hex('6000'))); end; error_return := 0; rgcbinit ( gcb ); info3 := tempinfo3; {NOW WE WANT INFO3 = EXPAND SCREEN SELECTION FOR BITMAP DISPLAYS} {info1 := tempinfo1; {NOW LET DISPLAY NAME BE SET CORRECTLY SFB 9/09/86} move := rmove; draw := rdraw; clear := rclear; text  := gle_soft_text; clip_limits := gle_soft_clip_limits; char_size := gle_soft_char_size; text_spacing := gle_soft_text_spacing; text_dir := gle_soft_text_dir; text_just  := gle_soft_text_just; marker := gle_soft_marker; marker_size := gle_soft_marker_size; set_marker := gle_soft_set_marker; index_color := rset_color; linestyle := rlinestyle; await_blanking := rawait_blanking; linewidth := rdummy_proc; inq_p1p2 := rget_p1p2; get_polygon_info := rget_polygon_info; calc_soft_text_xform := gle_text_xform; fill_index_color := rfill_index_color; graphics_on_off := rgraphics_on_off; cursor := rcursor; define_drawing_mode := rdefine_drawing_mode; polygon := rpolygon; define_color_map := rdefine_color_map;  buffer_mode := rdummy_proc; output_escapei := rdummy_proc; output_escapeo := rdummy_proc; flush_buffer := rdummy_proc; get_raster := rget_raster; soft_font_ptr := addr(font); case info1 of munknown : { reserved } ; m9816a : { 9816 } begin display_name := '9816A '; display_name_char_count := 5; display_res_x := 2.375; { 168mm X 126mm } display_res_y := 2.37301587301587; end; m9826a : { 9826 } begin display_name := '9826A '; display_name_char_count := 5; display_res_x := 3.325; { 120mm X 90mm } display_res_y := 3.322222222222222; end; m9836a : { 9836 } begin display_name := '9836A '; display_name_char_count := 5; display_res_x := 2.433333333333333; { 210mm X 160mm } display_res_y := 2.43125; end; m9836c : { 9836C } begin display_name := '9836C '; display_name_char_count := 5; display_res_x := 2.35483870967742; { 217mm X 163mm } display_res_y := 2.38650306748466; end; m98627a : { 98627 } begin display_name := '98627A'; display_name_char_count := 6; deviceaddress := info2; display_res_x := 3.333333333333333; display_res_y := 3.333333333333333; end; m9837a : { Gator Black/White } begin display_name := '9837a '; display_name_char_count := 5; {GATOR CONSTANTS CORRECTED 4/15/85 SFB} display_res_x := 3.27884; {1023/312} { 312% mm X 234mm } display_res_y := 3.27778; {767/234} if info3 = 1 then {added to detect current} begin {ymax. } n_glines := 768; hard_ymax := 767; end; await_blanking := rdummy_proc; setup_gator(gcb); clear := gator_clear; fill_index_color := gator_fill_index_color; define_color_map := rdummy_proc; end; mgatorbox: { Gatorbox SFB 4/15/85} begin display_name := '98700A'; {SFB 6/11/85} display_name_char_count := 6; display_res_x := 2.841667; {360mm X 270mm +/- 1.5%} display_res_y := 2.840740; if info3 = 1 then {added to detect current} begin  {ymax. } n_glines := 768; hard_ymax := 767; end; setup_gatorbox(gcb); clear := gatorbox_clear; end; mbobcat,mbobcatlores,mcatseye,mcatseye_hrx: {Bobcat SFB 4/15/85}  {added MCATSEYE SFB 9/09/86} begin setup_bobcat(gcb); clear := bobcat_clear; display_name_char_count := 6; fill_index_color := bobcat_fill_index_color; if (info1 = mbobcat) or (info1 = mcatseye) or (info1 = mcatseye_hrx) then { bobcat hires } begin {assume 98545/98547/98549 and change later if necessary. SFB} display_res_x := 2.841666667; {360mm X 270mm +/- 1.5%} display_res_y := 2.840740741; if pallette = 1 then if info1=mbobcat then begin {hires mono} display_name := '98544A'; {SFB 6/11/85, BUGFIX 9/09/86} display_res_x := 3.27884; {same as GATOR} display_res_y := 3.27778; end else begin  {hires mono CATSEYE} display_name := '98548A'; {SFB 2/9/86} display_res_x := 3.728862974; {19 inch monitor default} display_res_y := 3.733576642; end else {pallette <> 1} begin  {hires color} if info1 = mbobcat then if gamut = 15 then {ADDED SFB 9/09/86} display_name := '98545A' {SFB 6/11/85} else display_name := '98547A' {HEXAGON SFB 9/09/86} else if gamut=63 then display_name := '98549A' {LCC} else begin display_name := '98550A'; display_res_x := 3.728862974; {19 inch monitor default} display_res_y := 3.733576642; end; end; if info3 = 1 then {added to detect current} if (display_name<>'98548A') and (display_name<>'98550A') then {SFB 2/9/88} begin {ymax. } n_glines := 768; hard_ymax := 767; end else begin  {ymax. } n_glines := 1024; {true (to date) hi-res - SFB 2/9/88} hard_ymax := 1023; end; end {if info1 = mbobcat or mcatseye} else { bobcat lores } begin {color and mono have same spec} display_res_x := 2.433333; display_res_y := 2.432926; if pallette = 1 then {SFB 6/11/85} display_name := '98542A' else display_name := '98543A'; {BUGFIX SFB 9/09/86} if info3 = 1 then begin n_glines := 400; hard_ymax := 399; end; end; end; mvga_woodcut, {added WOODCUT CFB 8JUN91} mvgam_woodcut: {added MONO CFB 30JUL91} begin setup_woodcut(gcb); if info1 = mvga_woodcut then begin display_name := 'E640 '; display_name_char_count := 4; end else begin display_name := 'E640G '; display_name_char_count := 5; end; display_res_x := 2.206896552; {~290x210mm (14")} display_res_y := 2.285714286; if info3 = 1 then begin n_glines := 480; hard_ymax := 479; end; end; mmed_woodcut: {added WOODCUT%  CFB 8JUN91} begin setup_woodcut(gcb); display_name := 'E1024 '; display_name_char_count := 5; display_res_x := 3.413333333; {300x225mm (16")} display_res_y := 3.413333333; if info3 = 1 then begin  n_glines := 768; hard_ymax := 767; end; end; mhrx_woodcut, {added WOODCUT CFB 8JUN91} mhrxm_woodcut: {added MONO CFB 30JUL91} begin setup_woodcut(gcb); if info1 = mhrx_woodcut then begin display_name := 'E1280 '; display_name_char_count := 5; end else begin display_name := 'E1280G'; display_name_char_count := 6; end; display_res_x := 3.764705882;  {340x272mm (19")} display_res_y := 3.764705882; if info3 = 1 then begin n_glines := 1024; {changed from 1000 CFB 25OCT91} hard_ymax := 1023; end; end; end; {of case } display_handler_name := 'RASTER'; display_handler_char_count := 6; display_min_x := 0; display_min_y := 0; display_max_x := hard_xmax; display_max_y := hard_ymax; info1 := 0; info2 := display_max_x; info3 := 0;  info4 := display_max_y; gle_soft_clip_limits ( gcb ); { set default clipping limits } pen_draw_mode := 0; area_draw_mode := 0; pen_number := 1; info1 := 1; rset_color(gcb); end; end; end. { output } { } { Graphics Low End } { } { Module = GLE_SCLIP } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide software clipping routines. } { Rev history } { Created - 10-10-82  } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $search 'GLE_TYPES'$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 6000$ module gle_sclip; import gle_types; export procedure gle_soft_clip_limits ( gcb : graphics_control_block_ptr); implement procedure gle_soft_clip_limits ( gcb : graphics_control_block_ptr ); begin with gcb^ do begin clip_limits_xmin := info1; clip_limits_xmax := info2; clip_limits_ymin := info3; clip_limits_ymax := info4; end; end; end. { module gle_sclip } { } { Graphics Low End } { } { Module = GLE_STEXT } { Programer = BJS } { Date = 10-10-82 } { &  } { Purpose: To provide software text routines. } { Rev history } { Created - 10-10-82  } { Modified - 6-28-83 BJS Removed soft_text from export text. This } { procedure is imported from gle_astext. } { 12-08-83 BDS Put Range Check on around calculation of } {  dx and dy to eliminate random vectors. } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $search 'GLE_TYPES'$ $include 'OPTIONS'$ { ******************* COMPILER OPTIONS ******************* } $linenum 4000$ module gle_stext; import gle_types; export var font ['GLE_GLE_STROKE_TABLE'] : array [0..maxint] of gle_shortint; procedure gle_soft_char_size ( gcb : graphics_control_block_ptr ); procedure gle_soft_text_spacing ( gcb : graphics_control_block_ptr ); procedure gle_soft_text_dir ( gcb : graphics_control_block_ptr ); procedure gle_soft_text_just ( gcb : graphics_control_block_ptr ); procedure gle_text_xform ( gcb : graphics_control_block_ptr ); implement procedure gle_text_xform ( gcb : graphics_control_block_ptr); const fraction_adjust = 32768; res_adjust = 8; adjusted_cell_width = 7 * fraction_adjust; adjusted_cell_height = 9 * fraction_adjust; var i : integer; dx,dy : integer; begin with gcb^ do begin $RANGE ON$ for i := 0 to 15 do begin if i < 8 then begin dx := ((i-1) * char_width) div res_adjust; cosx_table[i] := (dx * text_cos_dir) div adjusted_cell_width; sinx_table[i] := (dx * text_sin_dir) div adjusted_cell_width; end; dy := ((i-4) * char_height) div res_adjust; siny_table[i] := (-dy * text_sin_dir) div adjusted_cell_height; cosy_table[i] := (dy * text_cos_dir) div adjusted_cell_height; end; dx := (char_width + char_space); text_space_x := ( dx * text_cos_dir ) div fraction_adjust; text_space_y := ( dx * text_sin_dir ) div fraction_adjust; dy := -(char_height + line_space); text_line_x := ( -dy * text_sin_dir ) div fraction_adjust; text_line_y := ( dy * text_cos_dir ) div fraction_adjust; $RANGE OFF$ { | added to avoid random vectors } calc_text_xform := 0; { transformation is not needed } end; end; procedure gle_soft_char_size ( gcb : graphics_control_block_ptr); begin with gcb^ do if (char_width <> info1) or (char_height <> info2) then begin calc_text_xform := 1; { calc new transform } char_width := info1; char_height := info2; end; end; procedure gle_soft_text_spacing ( gcb : graphics_control_block_ptr); begin with gcb^ do if (char_space <> info1) or (line_space <> info2) then begin calc_text_xform := 1; { calc new transform } char_space := info1; line_space := info2; end; end; procedure gle_soft_text_dir ( gcb : graphics_control_block_ptr); begin with gcb^ do if (text_cos_dir <> info1) or (text_sin_dir <> info2) then begin calc_text_xform := 1; { calc new transform } text_cos_dir := info1; text_sin_dir := info2; end; end; procedure gle_soft_text_just ( gcb : graphics_control_block_ptr); begin with gcb^ do if (char_just_x <> info1) or (char_just_y <> info2) then begin calc_text_xform := 1; { calc new transform } char_just_x := info1; cha& r_just_y := info2; end; end; end. { module gle_stext } $TABLES$ $LIST OFF$ { } { Graphics Low End } { } { Module = GLE_TYPES } { Programer = BJS } { Date = 10- 5-82 } {  } { Purpose: To define the graphics control blocks used by GLE. } { Rev history } { Created - 10- 5-82 BJS  } { Modified - 11-29-82 BJS Clean up and changed booleans to shortints } { Modified - 10- 8-84 SFB Gatorbox/Bobcat types added } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  } $tables on$ $modcal$ $include 'OPTIONS'$ { compiler options } $linenum 1000$ module gle_types; export type gle_byte = -128 .. 127; gle_shortint = -32768 .. 32767; anychar = packed array [1..maxint] of char; anychar_ptr = ^anychar; gle_char6 = packed array [1..6] of char; graphics_control_block_ptr = ^graphics_control_block; graphics_input_control_block_ptr = ^graphics_input_control_block; $page$ {****************************** OUTPUT **************************************} graphics_control_block = packed record info1 : integer; { holds info passed to and from GLE } info2 : integer; info3 : integer; info4 : integer; info_ptr1 : anyptr; info_ptr2 : anyptr; await_blanking : procedure ( gcb : graphics_control_block_ptr ); buffer_mode : procedure ( gcb : graphics_control_block_ptr ); char_size : procedure ( gcb : graphics_control_block_ptr ); clear : procedure ( gcb : graphics_control_block_ptr ); clip_limits : procedure ( gcb : graphics_control_block_ptr ); cursor : procedure ( gcb : graphics_control_block_ptr ); define_color_map : procedure ( gcb : graphics_control_block_ptr ); define_drawing_mode : procedure ( gcb : graphics_control_block_ptr ); draw : procedure ( gcb : graphics_control_block_ptr ); fill_index_color : procedure ( gcb : graphics_control_block_ptr ); flush_buffer : procedure ( gcb : graphics_control_block_ptr ); get_color_map : procedure ( gcb : graphics_control_block_ptr ); get_raster : procedure ( gcb : graphics_control_block_ptr ); get_polygon_info : procedure ( gcb : graphics_control_block_ptr ); gload : procedure ( gcb : graphics_control_block_ptr ); graphics_on_off : procedure ( gcb : graphics_control_block_ptr ); gstore : procedure ( gcb : graphics_control_block_ptr ); index_color : procedure ( gcb : graphics_control_block_ptr ); inq_p1p2 : procedure ( gcb : graphics_control_block_ptr ); linewidth : procedure ( gcb : graphics_control_block_ptr ); linestyle : procedure ( gcb : graphics_control_block_ptr ); marker : procedure ( gcb'  : graphics_control_block_ptr ); marker_size : procedure ( gcb : graphics_control_block_ptr ); move : procedure ( gcb : graphics_control_block_ptr ); output_escapei : procedure ( gcb : graphics_control_block_ptr ); output_escapeo : procedure ( gcb : graphics_control_block_ptr ); polygon : procedure ( gcb : graphics_control_block_ptr ); set_marker : procedure ( gcb : graphics_control_block_ptr ); text : procedure ( gcb : graphics_control_block_ptr ); text_dir : procedure ( gcb : graphics_control_block_ptr ); text_just : procedure ( gcb : graphics_control_block_ptr ); text_spacing : procedure ( gcb : graphics_control_block_ptr ); dummy_xxx  : procedure ( gcb : graphics_control_block_ptr ); io_inq_timeout : procedure ( anyvar iocb_ptr : anyptr; var value : integer); io_read : procedure ( anyvar iocb_ptr, dev_buf_ptr : anyptr ); io_set_timeout : procedure ( anyvar iocb_ptr : anyptr; value : integer); io_term : procedure ( anyvar iocb_ptr : anyptr ); io_write : procedure ( anyvar iocb_ptr, dev_buf_ptr : anyptr ); iocb : anyptr; { ptr to io system dependent info } device_buf : anyptr; { ptr to device dependent buffer } dev_dep_stuff : anyptr; { ptr to device dependent information } device_info : anyptr; { pointer to device identifier (e.g. 3) } device_info_char_count : gle_shortint; { # char in device_info } error_return : gle_shortint; { used by some procedures } spooling : gle_shortint; { '1' if output goes to a file } display_name : gle_char6; { name of display device } display_name_char_count : gle_shortint; { # chars used in display_name } display_handler_name : gle_char6; { 'HPGL', 'RASTER', 'GPIS' } display_handler_char_count : gle_shortint; { # chars used in display_handler_name } display_res_x : real; { points per mm in x direction } display_res_y : real; { points per mm in y direction } display_min_x : integer; { minimum x device coordinate } display_min_y : integer; { minimum y device coordinate } display_max_x : integer; { maximum x device coordinate } display_max_y : integer; { maximum y device coordinate } { general info stuff } background : gle_shortint; { '1' if drawing in color 0 supported, '0' if not } complement_support : gle_shortint; { '1' if complement drawing supported } non_dominant_support : gle_shortint; { '1' if non-dominant drawing supported } erase_support : gle_shortint; { '1' if erase drawing supported } color_map_support : gle_shortint; { '1' if color map supported } polygon_support : gle_shortint; { '1' if polygons are supported } redef_background : gle_shortint; { '1' if color 0 can be changed } polygon_fill_factor : gle_shortint; { aprox size of a line in device units } polygon_solid_fill : gle_shortint; { fill line spacing which is used for doild fill } dither_support : gle_shortint; { '1' if polygons use dither } pallette : integer; { number of distinct colors supported } gamut : integer; { number of colors which can appear at same time} cont_linestyles : gle_shortint; { number of continuous linestyles supported } vect_linestyles : gle_shortint; { number of vector adjusted linestyles supported } linewidths : gle_shortint; { number of linewidths supported } char_sizes : gle_shortint; { number of character sizes supported, -1 for continuously varying sizes } { current value information } current_pos_x : integer; { last point used } current_pos_y : integer; end_x : integer; end_y : integer; marker_type : gle_shortint; marker_width : integer; marker_height : integer; kata : gle_shortint; { '1' if kata char set to be used } char_width : integer; { current character info } char_heigh' t : integer; char_space : integer; line_space : integer; text_sin_dir : integer; text_cos_dir : integer; char_just_x : integer; char_just_y : integer; clip_limits_xmin : integer; clip_limits_xmax : integer; clip_limits_ymin : integer; clip_limits_ymax : integer; current_cursor_state : gle_shortint; { off = 0; on = 1 } current_cursor_x : integer; current_cursor_y : integer; current_buffer_mode : gle_shortint; { buffered = 1; unbuffered = 0 } current_linestyle : gle_shortint; current_linestyle_pattern : gle_shortint; current_pattern_length : gle_shortint; current_linestyle_mode : gle_shortint; current_color_index : gle_shortint; current_fill_index : gle_shortint;  current_drawing_mode : gle_shortint; current_linewidth : gle_shortint; current_polygon_color : gle_shortint; { index, -1 if rgb } current_polygon_red : gle_shortint; current_polygon_green : gle_shortint; current_polygon_blue : gle_shortint; { temp storage of some regs } old_a5 : integer; old_a6 : integer; { software text stuff } text_space_x : integer; { spacing x&y after characters } text_space_y : integer; text_line_x : integer; { linefeed spacing } text_line_y : integer; cosx_table : packed array [0..7] of gle_shortint; cosy_table : packed array [0..15] of gle_shortint; sinx_table : packed array [0..7] of gle_shortint; siny_table : packed array [0..15] of gle_shortint; calc_text_xform : gle_shortint; { '1' if text xform needs to be recalculated } calc_soft_text_xform : procedure ( gcb : graphics_control_block_ptr ); soft_font_ptr : anyptr; { points to font table } soft_text_temp1 : integer; soft_text_temp2 : integer; { software clipping stuff } unclipped_move : procedure ( gcb : graphics_control_block_ptr ); unclipped_draw : procedure ( gcb : graphics_control_block_ptr ); soft_clip_savex0 : integer; soft_clip_savex1 : integer; soft_clip_savey0 : integer; soft_clip_savey1 : integer; soft_clip_switch : gle_shortint; soft_clip_cpx : integer; soft_clip_cpy : integer; end; $page$ {***************************** INPUT ****************************************} graphics_input_control_block = packed record info1 : integer; { holds info passed to and from GLE } info2 : integer; info3 : integer; info4 : integer; info_ptr1 : anyptr; get_digitize : procedure ( gcb : graphics_input_control_block_ptr ); inq_p1p2 : procedure ( gcb : graphics_input_control_block_ptr ); input_echo : procedure ( gcb : graphics_input_control_block_ptr ); input_escapei : procedure ( gcb : graphics_input_control_block_ptr ); input_escapeo : procedure ( gcb : graphics_input_control_block_ptr ); sample : procedure ( gcb : graphics_input_control_block_ptr ); start_digitize : procedure ( gcb : graphics_input_control_block_ptr ); dummy_xxx : procedure ( gcb : graphics_input_control_block_ptr ); io_inq_timeout : procedure ( anyvar iocb_ptr : anyptr; var value : integer); io_read : procedure ( anyvar iocb_ptr, dev_buf_ptr : anyptr ); io_set_timeout : procedure ( anyvar iocb_ptr : anyptr; value : integer); io_term : procedure ( anyvar iocb_ptr : anyptr ); io_write : procedure ( anyvar iocb_ptr, dev_buf_ptr : anyptr ); iocb : anyptr; { ptr to io system dependent info } device_buf : anyptr; { ptr to device dependent buffer } dev_dep_stuff: anyptr; { ptr to device dependent information } device_info : anyptr; { pointer to device identifier (e.g. 701) } device_info_char_count : gle_shortint; { # char in device_info } error_return : gle_shortint; { used by some procedures } input_name : gle_char6; { name of display device } input_name_char_count : gle_shortint; { # chars used in display_name } input_handler_name : gle_char6; { 'HPGL', 'KNOB', 'GPIS' } inp( ut_handler_char_count : gle_shortint; { # chars used in display_handler_name } input_res_x : real; { points per mm in x direction } input_res_y : real; { points per mm in y direction } input_min_x : integer; { input, min and max device coordinates } input_max_x : integer; input_min_y : integer; input_max_y : integer; input_cpx : integer; { Where device dependent echoes are started } input_cpy : integer; end; status_def = packed record bit15,bit14,bit13,bit12,bit11,bit10,bit9,bit8, notbusy,bit6,vblank,bit4,hz50,monochrome,bit1,bit0 : boolean; end; w_array = packed array[1..maxint] of gle_shortint; const munknown = 0; m9816a = 1; m9826a = 2; m9836a = 3; m9836c = 4; m98627a = 5; m9837a = 6; mgator_c = 7; { 7,8,9 new for 3.1 SFB } mgatorbox = 7; mbobcat = 8; mbobcatlores = 9; mcatseye = 10; {98549A - SFB 2/9/88} mcatseye_hrx = 11; {98548A, 98550A - SFB 2/23/88} mvga_woodcut = 12; {CFB 7JUN91} mmed_woodcut = 13; {CFB 7JUN91} mhrx_woodcut = 14; {CFB 7JUN91} mvgam_woodcut= 15; {CFB 30JUL91} mhrxm_woodcut= 16; {CFB 30JUL91} no = 0; yes = 1; var rule_reg : ^gle_shortint; { [HEX('564008')] : gle_shortint;} width_reg : ^gle_shortint; { [HEX('56400C')] : gle_shortint;} inq_buffer: ^gle_shortint; { [HEX('564100')] : packed array [0..maxint] of gle_shortint;} crt : ^w_array; { [ HEX('566000') ] : word_array;} status : ^status_def; { [ hex('564000') ] : status_def;} ww_reg : ^gle_shortint; { [ hex('564108') ] : gle_shortint;} blink1_reg [ hex('564100') ] : gle_shortint; blink2_reg [ hex('564104') ] : gle_shortint; write_to_status : boolean; control_space : integer; implement $page$ end. { GLE_TYPES } $LIST ON$ { } { Graphics Low End } { } { Module = GLE_UTLS } { Programer = BJS } { Date = 11-15-82 } {  } { Purpose: To provide general GLE tools } { Rev history } { Created - 11-15-82  } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_TYPES'$ $sysprog$ $include 'OPTIONS'$ { ***************** COMPILER OPTIONS ********************** } $linenum 21000$ module gle_utls; import gle_types; export function gle_read_integer ( size : gle_shortint; s : anychar_ptr; var count : gle_shortint ) : gle_shortint; procedure gle_write_integer ( value : gle_shortint; var size : gle_shortint; s : anychar_ptr ); procedure gle_copy_to_string ( s : anychar_ptr; sl : gle_shortint; var d : string ); function gle_match ( size1 : gle_shortint; s1 : anychar_ptr; size2 : gle_shortint; s2 : anychar_ptr ) : boolean;(  function gle_shortint_min ( p1,p2 : gle_shortint ) : gle_shortint; function gle_shortint_max ( p1,p2 : gle_shortint ) : gle_shortint; $PAGE$ implement function gle_shortint_min ( p1,p2 : gle_shortint ) : gle_shortint; { Purpose : To return the minimum 16 bit integer } begin if p1 < p2 then gle_shortint_min := p1 else gle_shortint_min := p2; end; { gle_shortint_min } function gle_shortint_max ( p1,p2 : gle_shortint ) : gle_shortint; { Purpose : To return the maximum 16 bit integer } begin if p1 > p2 then gle_shortint_max := p1 else gle_shortint_max := p2; end; { gle_shortint_max } procedure gle_write_integer ( value : gle_shortint; var size : gle_shortint; s : anychar_ptr ); { Purpose : To convert a 16 bit signed integer to ASCII } var t : packed array [1..20] of char; i : gle_shortint; temp_value : gle_shortint; digit : gle_shortint; begin temp_value := abs(value); i := 0; repeat i := i + 1; digit := temp_value mod 10; t[i] := chr((digit) + 48); temp_value := temp_value div 10; until temp_value = 0; if value < 0 then begin i := i + 1; t[i] := '-'; end; size := i; for i := i downto 1 do s^[size-i+1] := t[i]; end; { write_integer } function gle_read_integer( size : gle_shortint; s : anychar_ptr; var count : gle_shortint ) : gle_shortint; { Purpose : To convert from ASCII to a 16 bit signed integer } var value : gle_shortint; neg  : boolean; digit : gle_shortint; i : gle_shortint; start : gle_shortint; begin i := 1; while (s^[i] = ' ') and ( i <= size ) do i := i + 1; if i > size then escape(-8); if s^[i] = '-' then begin i := i + 1; neg := true; end else neg := false; value := 0; start := i; while (s^[i] >= '0') and (s^[i] <= '9') and (i <= size) do begin digit := ord(s^[i]) - 48; value := value * 10 + digit; i := i + 1; end; if (i > size+1) or (i = start) then escape(-8); count := i; { next free byte } if neg then value := -value; gle_read_integer := value; end; { read_integer } procedure gle_copy_to_string ( s : anychar_ptr; sl : gle_shortint; var d : string ); { Purpose : To convert from a packed array of char to string format } var i : gle_shortint; begin setstrlen(d,sl); for i := 1 to sl do d[i] := s^[i]; end; { copy_to_string } function gle_match ( size1 : gle_shortint; s1 : anychar_ptr; size2 : gle_shortint; s2 : anychar_ptr ) : boolean; { Purpose : To return true if the two packed array of char match } var i : gle_shortint; begin if size1 = size2 then begin i := 1; $partial_eval on$ while (i <= size1) and (s1^[i] = s2^[i]) do i := i + 1; gle_match := i > size1; end else gle_match := false; end; { match } end. { } { Graphics Low End } { } { Module = GLE_HPHIL_RELI } { Programmer= SFB } { Date = 9/09/85 } {  } { Purpose: To provide HPHIL relative locator input handler routines. } { Rev history } { Created - 3-20-85  } { Hacked from GLE_HILI 9/9/85 SFB } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival pur) poses is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $SEARCH 'RGL', 'GLE_TYPES','GLE_UTLS', 'GLE_RGL', 'GLE_HILI'$ {$SEARCH '*LIBRARY.'$} $modcal$ $DEBUG OFF$ $INCLUDE 'OPTIONS'$ { ******************* COMPILER OPTIONS ******************* } $LINENUM 18000$ $ALLOW_PACKED ON$ {SFB 4/11/85} module gle_hphil_reli; import gle_types, sysdevs; export procedure gle_init_hphil_rel_input ( gcbi : graphics_input_control_block_ptr); implement import sysglobals, gle_utls, iocomasm, GLE_RAS_OUT, GLE_HPHIL_ABSI {for dvr_rec, of all things!}; var dev : integer; digitize_enabled : boolean; last_button : integer; {see gle_knob for usage} procedure hphil_rel_input_escapeo ( gcbi : graphics_input_control_block_ptr ); begin { with gcbi^ do begin end; } end; procedure hphil_rel_input_escapei ( gcbi : graphics_input_control_block_ptr ); begin { with gcbi^ do begin end; } end; procedure hphil_rel_get_input_hard_clip(gcbi : graphics_input_control_block_ptr ); var i, w,h : integer; found : boolean; begin w := 0; h := 0; found := false; with gcbi^ do begin dev := 0;  for i:=1 to 7 do {scale off first active abs locator} with loopcontrol^.loopdevices[i].descrip, dvr_rec^ do begin if (NOT abscoords) and (bit_set(devices, i-1)) and (numaxes > 0) then {only active devices} begin if not found then begin dev := i; {scale off first locator found} info1 := 0; info2 := input_max_x; info3 := 0; info4 := input_max_y; end; maxcountx := info2; {and make accessible to driver} maxcounty := info4; {for ALL active locators} found := true; end; end; if not found then begin dvr_rec^.devices := 127; {reenable locators that may have been masked} escape(-26); end; end; end; procedure hphil_rel_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); begin {set p1, p2 to hard clip limits for hphil abs locators} hphil_rel_get_input_hard_clip(gcbi); end; procedure read_hphil_rel(var x, y : integer; var button : integer); var achar : char; havebutton : boolean; begin if last_button < 0 then button := -1 else button := 0; with dvr_rec^ do begin reading := true; {tell driver not to update dvr_comm_rec} x := xloc; y := yloc; havebutton := false;  if ncodes > 0 then {pick up first button encountered only} begin achar := codes[1]; {don't read kbd here, as we wish to re-enable REL asap} havebutton := true; end; call(update, dvr_rec); reading := false;  if (not havebutton) and (extend <> 0) {kbd_terminator} then {NOW we can try keyboard} with fibp(gfiles[2])^ do {gfiles[2]^ is fib for keyboard file var} begin call(unitable^[funit].tm, fibp(gfiles[2]), unitstatus, fibp(gfiles[2])^, 0, 0); if not fbusy then begin read(gfiles[2]^, achar); havebutton := true; end; end; if havebutton then if digitize_enabled then begin if last_button = 0 then begin last_button := -ord(achar); button := -1; end end else button := ord(achar); end; end; procedure hphil_rel_sample ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do begin read_hphil_rel(info1, info2, info3); input_cpx := info1;  input_cpy := info2; end; end; procedure hphil_rel_start_digitize ( gcbi : graphics_input_control_block_ptr ); begin digitize_enabled := true; with dvr_rec^ do begin reading := true; {tell driver not to interfere} ncodes := ) 0; {cancel previous buttons} latch := true; {in await_locator} active := true; {ensure we're now sampling} call(update, dvr_rec); {flush any pending dvr data to dvr_comm_rec} reading := false; {let driver update record with future data} end; last_button := 0; end; procedure hphil_rel_get_digitize ( gcbi : graphics_input_control_block_ptr ); begin digitize_enabled := false; with gcbi^ do begin read_hphil_rel(info1, info2, info3); info3 := abs(last_button); end; with dvr_rec^ do {erase from driver the button read into info3} begin reading := true; {tell driver not to interfere} ncodes := 0; {cancel button read} latch := false; {allow updates w/new driver data} call(update,dvr_rec); {flush any pending driver data} reading := false; {allow driver updates} end; last_button := 0; end; procedure hphil_rel_input_echo ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do if info1 <> 0 then begin beep; {use 8042 (HPHIL controller) beeper for echo 1} end; end; procedure gle_init_hphil_rel_input ( gcbi : graphics_input_control_block_ptr); const defaultx = 0; defaulty = 0; begin with gcbi^ do begin error_return := 0; dvr_rec := gcbi^.info_ptr1; {get comm_rec_ptr from DGL_CONFIG_IN} try {check for device actually attached to rel driver} hphil_rel_get_input_hard_clip ( gcbi ); {escapes if no locator} {to get here there was at least one rel locator found on HPHIL. The configure operation in the HPHIL module will have got the loopdriver connected to all rellocators with IDs in proper range.} dvr_rec^.extend := 1;  {instead of line below} {kbd_terminator := true; {says a keypress can terminate await_locator} with dvr_rec^ do begin reading := true; {tell driver not to interfere} ncodes := 0; {toss any previous buttons} latch := false; {disarm the digitize function} active := true; {allow driver to start acquiring data} xloc := defaultx; {set initial x,y} yloc := defaulty; reading := false; {and sending to dvr_rec} end; sample  := hphil_rel_sample; start_digitize := hphil_rel_start_digitize; get_digitize := hphil_rel_get_digitize; inq_p1p2 := hphil_rel_get_input_p1p2; input_echo := hphil_rel_input_echo; input_escapei := hphil_rel_input_escapei; input_escapeo := hphil_rel_input_escapeo; input_handler_name := 'HILREL'; {SFB} input_handler_char_count := 6; input_name := 'HILREL'; {SFB} input_name_char_count := 6; input_min_x := info1; input_max_x := info2; input_min_y := info3; input_max_y := info4; input_cpx := input_min_x; input_cpy := input_min_y; last_button := 0; digitize_enabled := false; with loopcontrol^.loopdevices[dev].descrip do if size16 then begin  input_res_x := counts/10.0; input_res_y := counts/10.0; end else begin input_res_x := counts/1000.0; input_res_y := counts/1000.0; end; recover if escapecode = -26 then error_return := 1 {hphil_rel_get_input_hard_clip failed, so no locator on loop} else escape(escapecode); {other error encountered in init} end; {with gcbi^} end; end. { hpgl_input } { } { Pascal work station graphics library } { } { Module = DGL_LIB  } { Programer = BJS } { Date = 2/1/81 } { Rev history: *  } { 5/21/82 BJS Set display and locator names to ' ' on term } { 5/21/82 BJS Fixed inverted window/set_echo_pos bug } { 8/25/82 BJS Major mods for GLE  } { 2/17/84 BDS Changed dynamic to global allocation for Pascal 3.0 } { 4/09/85 SFB Added HPHIL locator esc support opcodes 1090, 4290 } { Purpose: Hold normal user interface routines } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $include 'OPTIONS'$ $linenum 20000$ $SEARCH_SIZE 15$ $search 'TYPES', 'DGL_VARS', 'GEN', 'GLE_LIB', 'DGL_C_OUT', 'DGL_C_IN', 'DGL_TOOLS', 'DGL_AUTL', 'DGL_IBODY'$ module DGL_LIB; import dgl_types; export procedure graphics_init; procedure set_aspect (x, y : real); procedure set_viewport (vxmin, vxmax, vymin, vymax : real ); procedure set_window (wxmin, wxmax, wymin, wymax : real ); procedure display_finit ( fname : gstring255; device_name : gstring255; control : integer; var ierr : integer ); procedure display_init ( dev_adr : integer; control : integer; var ierr : integer ); procedure display_term;  procedure make_pic_current; procedure set_timing ( opcode : integer ); procedure graphics_term; procedure locator_term; procedure set_color_model ( model : integer); procedure set_line_style ( index : integer); procedure set_color ( index : integer); procedure set_line_width ( index : integer); procedure locator_init ( dev_adr : integer; var ierr : integer ); function graphicserror : integer; procedure move (x,y:real ); procedure line (x,y:real ); procedure int_polyline ( num_points : integer; anyvar xvec, yvec : gshortint_list ); procedure polyline ( num_points : integer; anyvar xvec, yvec : greal_list ); procedure int_move (ix,iy : gshortint); procedure int_line (ix,iy : gshortint); procedure marker (marker_number : integer); procedure set_display_lim ( dxmin, dxmax, dymin, dymax : real; var ierr : integer); procedure clear_display; procedure input_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); procedure output_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); procedure set_text_rot (dx, dy : real); procedure set_char_size (width,height : real); procedure gtext( s : gstring255 ); procedure set_echo_pos (wx,wy : real); procedure await_locator ( echo : integer; var button : integer; var rx, ry : real ); procedure sample_locator ( echo : integer; var rx, ry : real ); procedure set_locator_lim ( lxmin,lxmax,lymin,lymax : real; var ierr : integer  ); procedure set_color_table ( index : integer; parm1 : real; parm2 : real; parm3 : real); procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real); procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real); implement import sysglobals, sysdevs, {asm,} dgl_vars, dgl_autl, dgl_gen, gle_types, gle_GEN, gle_geni, gle_hphil_absi, {SFB 4/9/85} dgl_confg_out, dgl_confg_in, *  dgl_tools, dgl_ibody, iodeclarations; {procedure hpm_dispose ( var object : anyptr; bytesize : integer ); external;} function graphicserror : integer; { Purpose: To return the most resent graphics error number } begin  graphicserror := graphics_error; end; { graphicserror } procedure display_move ( x,y : integer ); begin with gle_gcb^ do begin end_x := x; end_y := y; call (move,gle_gcb); end; end; procedure display_draw ( x,y : integer );  begin with gle_gcb^ do begin end_x := x; end_y := y; call (draw,gle_gcb); end; end; procedure adjust_echo (var dx,dy : integer); { Purpose : To adjust echo for rubber band line effects } begin case current_echo_type of  5 : dy:=d_loc_echo_y; { horz rubber band line } 6 : dx:=d_loc_echo_x; { vert rubber band line } 7 : { snap horz / vert rubber band line } if abs(dx-d_loc_echo_x) >= abs(dy-d_loc_echo_y) then dy:=d_loc_echo_y else dx:=d_loc_echo_x; otherwise ; { all other echos are ok } end; { of case } end; { adjust_echo } procedure cursor ( x,y : integer); begin display_move(x-8,y); display_draw(x+8,y); display_move(x,y+8); display_draw(x,y-8); end; procedure echo_cursor (dx,dy : integer); { Purpose : To perform the current echo on a raster display } begin case current_echo_type of 1,2 : cursor(dx,dy); 3 : with gcb^,gcb^.max_disp_lim do begin {full screen} display_move(trunc(xmin),dy); display_draw(trunc(xmax),dy); display_move(dx,trunc(ymin)); display_draw(dx,trunc(ymax)); display_move(dx,dy); { set cp to cursor center } end; 4,5,6,7 : begin {rubber bands} adjust_echo (dx,dy); { are dx, dy correct for this echo? } display_move(d_loc_echo_x,d_loc_echo_y); display_draw(dx,dy); cursor(dx,dy); end; 8 : begin {rubber band box} display_move(d_loc_echo_x,d_loc_echo_y); display_draw(d_loc_echo_x,dy); display_draw(dx,dy); display_draw(dx,d_loc_echo_y); display_draw(d_loc_echo_x,d_loc_echo_y); cursor(dx,dy); end; otherwise ; { no echo } end; { of case } end; { display_echo } procedure DGL_CURSOR ( gle_gcb : graphics_control_block_ptr ); VAR x,y : integer; CPX : INTEGER; CPY : INTEGER; begin with gle_gcb^ do begin x := info1; y := info2; CPX := CURRENT_POS_X; { SAVE CP } CPY := CURRENT_POS_Y; gle_await_blanking(gle_gcb); if current_cursor_state = 1 then { remove old cursor } echo_cursor (current_cursor_x, current_cursor_y); if (info3 = 1) then { draw new cursor } echo_cursor (x,y); current_cursor_state := info3; current_cursor_x := x; current_cursor_y := y; END_X := CPX; { RESTORE CP } END_Y := CPY; GLE_MOVE(GLE_GCB); end; end; procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real); var dx,dy : real; begin ck_system_init; ck_display_init; dx := wx * xwtod_scale + xwtod_offset; dy := wy * ywtod_scale + ywtod_offset; with gcb^,gcb^.max_disp_lim,gle_gcb^ do begin mmx := (dx - xmin) / display_res_x; mmy := (dy - ymin) / display_res_y; end; end; procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real); var dx,dy : real; tx,ty : real; begin ck_system_init; ck_locator_init; dx := wx * xwtod_scale + xwtod_offset; dy := wy * ywtod_scale + ywtod_offset; with gcb^,gle_gcbi^ do begin { convert display to locator } tx := ((dx-cur_disp_lim.xmin) / xltod_scale) + log_loc_lim.xmin; ty := ((dy-cur_disp_lim.ymin) / yltod_scale) + log_loc_lim.ymin; { convert to mm } mmx := (tx - max_loc_lim.xmin) / input_res_x; mmy := (ty - max_loc_lim.ymin) / input_res_y; end; end; procedure set_viewport (vxmin, vxmax, vymin, vymax : real ); { Purpose: To set the viewport } begin ck_system_init; {ck parms} if (vxmin >= vxm+ ax) or (vymin >= vymax) then error (err_bad_parms); with gcb^ do begin if (vxmin < 0.0) or {ck with vir limits} (vymin < 0.0) or (vxmax > cur_vir_lim.xlim) or (vymax > cur_vir_lim.ylim) then error (err_out_virt); with viewport_lim do begin xmin := vxmin; { set the new limits } xmax := vxmax; ymin := vymin; ymax := vymax; end; calculate_viewing; { set flag so character size will be recalculated } calc_text_xform := true; end end; { set_viewport } procedure set_window (wxmin, wxmax, wymin, wymax : real ); { Purpose: To set the window } begin ck_system_init; {ck parms} if (wxmin = wxmax) or (wymin = wymax) then error (err_bad_parms); with gcb^ do with window_lim do begin xmin := wxmin; { set the new window } xmax := wxmax; ymin := wymin; ymax := wymax; end; calculate_viewing; { set flag so character xform will be recalculated } calc_text_xform := true; end; { set_window } procedure set_aspect (x, y : real); { Purpose: To set the aspect ratio } begin ck_system_init; {ck parms } if (x <= 0.0) or (y <= 0.0) then error (err_aspect); with gcb^ do { calc new limits } with cur_vir_lim do begin aspect_ratio := y / x; if aspect_ratio <= 1.0 then begin xlim := 1.0; ylim := aspect_ratio; end else begin xlim := 1.0 / aspect_ratio;  ylim := 1.0; end; { set viewport to new limits } set_viewport( 0.0, xlim, 0.0, ylim); end; end; { set_aspect } procedure make_pic_current; begin ck_system_init; ck_display_init; gle_flush_buffer ( gle_gcb ); end; procedure set_timing ( opcode : integer ); begin ck_system_init; if (opcode < 0) or (opcode >1) then error(err_bad_parms); gcb^.dgl_current_timming_mode := opcode; if disp_init then begin gle_gcb^.info1 := opcode; gle_buffer_mode ( gle_gcb ); end; end; procedure set_color_model ( model : integer); begin ck_system_init; if (model<1) or (model>2) then error(err_bad_parms); gcb^.dgl_current_color_model := model; end; procedure set_color_table ( index : integer; parm1 : real; parm2 : real; parm3 : real); begin ck_system_init; ck_display_init; with gcb^,gle_gcb^ do begin if (index >= 0) and (index <= color_table_size) then begin dgl_polygon_color_current := false; { dither pattern is wrong } if ((0 > parm1) or (parm1 > 1)) or ((0 > parm2) or (parm2 > 1)) or ((0 > parm3) or (parm3 > 1)) then error (err_bad_parms); call (proc_color_table,index,parm1,parm2,parm3); { always recalculate line color (2.1 buug fix) } call (proc_color,dgl_current_color); end; end; end; procedure set_line_width (index : integer); { Purpose: To set the line width primitives will be drawn with } begin ck_system_init; ck_display_init; with gle_gcb^ do begin if (index < 1 ) or ( index > linewidths ) then index := 1; gcb^.dgl_current_linewidth := index; info1 := index; gle_linewidth ( gle_gcb ); end; end; { set_linewidth } procedure set_color (index : integer); { Purpose: To set the color primitives will be drawn with } begin ck_system_init; ck_display_init; with gcb^,gle_gcb^ do begin if (index < 0) or ((index > gamut) and ((color_table_size = 0) or (index > color_table_size))) then index := 1; { optimize changing color on raster devices (2.1 bug fix) } if ((dgl_current_color <> index) or (complement_support <> 1)) then begin call (proc_color,index); dgl_current_color := index; end; end; end; { set_color } procedure set_line_style ( index : integer); { Purpose: To set the linestyle that primitives are drawn with } begin ck_system_init; ck_display_init; with gcb^ do begin if (index < 1) or (index > number_dgl_linestyles) then index := 1; {if dgl_current+ _linestyle <> index then begin} dgl_current_linestyle := index; call (proc_linestyle,index); {end;} end; end; { set_line_style } procedure set_display_lim ( dxmin, dxmax, dymin, dymax : real; var ierr : integer); { Purpose : To set the logical display limits } var txmin : real; txmax : real; tymin : real; tymax : real; begin ck_system_init; ck_display_init; { ck parms } if ((dxmin < dxmax) and (dymin < dymax)) then with gcb^ do with max_disp_lim do begin with gle_gcb^ do begin txmin := (dxmin * display_res_x) + xmin; txmax := (dxmax * display_res_x) + xmin; tymin := (dymin * display_res_y) + ymin; tymax := (dymax * display_res_y) + ymin;  end; { make sure new logical imits are within the physical limits } if (txmin >= xmin) and (txmax <= xmax + eight_diget_epsilon) and (tymin >= ymin) and (tymax <= ymax + eight_diget_epsilon) then begin display_limits (txmin,txmax,tymin,tymax); { set flag indicating that the char size needs to be recalculated. This is done since the physical character size may change due to this procedure } calc_text_xform := true; ierr := 0; end else ierr := 2; end else ierr := 1; end; { set_display_lim } procedure clear_display; { Purpose : To clear to display } begin ck_system_init; ck_display_init; with gle_gcb^ do  begin info1 := -1; { clear all planes } info2 := gcb^.dgl_background_index; gle_clear ( gle_gcb ); end; end; { Clear_display } $stackcheck off$ procedure move (x, y : real); { Purpose : To change the current position  } begin if disp_init then begin { save world cp } int_cp := false; { cp saved as real value } world_real_cpx := x; world_real_cpy := y; { calc new device dependent cp } cpx := trunc ( x * xwtod_scale + xwtod_offset ); cpy := trunc ( y * ywtod_scale + ywtod_offset ); with gle_gcb^ do begin end_x := cpx; end_y := cpy; call (move,gle_gcb); end; end else if system_init then error (err_dis_int) else error (err_sys_int); end; { move } procedure line (x, y : real); { Purpose : To draw a line } begin if disp_init then begin { save world cp } int_cp := false; { cp saved as real value } world_real_cpx := x; world_real_cpy := y; { calc new device dependent cp } cpx := trunc ( x * xwtod_scale + xwtod_offset ); cpy := trunc ( y * ywtod_scale + ywtod_offset ); with gle_gcb^ do begin end_x := cpx; end_y := cpy; call (draw,gle_gcb); end; end else if system_init then error (err_dis_int) else error (err_sys_int); end; { line } procedure int_move (ix, iy : gshortint); { Purpose : To move the current position } begin if disp_init then begin { use the normal move routine unless the short flag is set } if short_flag then begin { save world cp } int_cp := true; { cp saved as gshortint } world_int_cpx := ix; world_int_cpy := iy; with gle_gcb^ do begin end_x := ix; end_y := iy; dgl_scaled_move; { perform a scaled move } end; end else move(ix,iy); end else if system_init then error (err_dis_int) else error (err_sys_int); end; { int_move } procedure int_line (ix, iy : gshortint); { Purpose : To set the logical display limits } begin if disp_init then begin { use normal line unless short_flag is set } if short_flag then begin  { save world cp } int_cp := true; { cp saved as gshortint } world_int_cpx := ix; world_int_cpy := iy; with gle_gcb^ do begin end_x := ix; end_y := iy; dgl_scaled_draw; { perform a scaled draw } end; end ,  else line(ix,iy); end else if system_init then error (err_dis_int) else error (err_sys_int); end; { int_line } procedure int_polyline ( num_points : integer; anyvar xvec, yvec : gshortint_list ); var i : integer; begin ck_system_init; ck_display_init; if num_points <= 0 then error(err_neg_points); int_move ( xvec[1], yvec[1] ); for i := 2 to num_points do int_line ( xvec[i], yvec[i]); end; procedure polyline ( num_points : integer; anyvar xvec, yvec : greal_list ); var i : integer; begin ck_system_init; ck_display_init; if num_points <= 0 then error(err_neg_points); move ( xvec[1], yvec[1] ); for i := 2 to num_points do line ( xvec[i], yvec[i]); end; $stackcheck on$ procedure gtext( s : gstring255 ); { PURPOSE : To draw a text string } begin if disp_init then begin if calc_text_xform then with gcb^ do begin set_char_size (dgl_char_width, dgl_char_height); set_text_rot (char_rot_w, char_rot_h); calc_text_xform := false; end; with gle_gcb^ do begin info_ptr1 := addr(s[1]); info1 := strlen(s); end; gle_text ( gle_gcb ); end else if system_init then error (err_dis_int) else error (err_sys_int); end; { gtext } procedure marker ( marker_number : integer ); begin ck_system_init; ck_display_init; if (marker_number < 1) or (marker_number > 19) then marker_number := 1; with gle_gcb^ do begin info1 := marker_number; gle_set_marker ( gle_gcb ); gle_marker ( gle_gcb ); end; end; procedure input_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var  ierr : integer ); { Purpose : To perform an input escape function } begin ck_system_init; ck_display_init; ierr := opcode_ck ( opcode,isize,rsize); call (gcb^.proc_input_esc,opcode,isize,rsize,ilist,rlist,ierr); end; { input_esc } procedure output_esc ( opcode : integer; isize : integer; rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer ); { Purpose : To perform an output escape funtion } begin ck_system_init; ck_display_init; ierr := opcode_ck ( opcode,isize,rsize); call (gcb^.proc_output_esc,opcode,isize,rsize,ilist,rlist,ierr); end; { output_esc } procedure set_text_rot (dx, dy : real); { PURPOSE : To set the new text rotation vectors } { calc normalize vector and save } { set flag so text xform is recalculated } var r : real; begin ck_system_init; ck_display_init; if (dx = 0) and (dy = 0) then error (err_bad_parms); with gcb^ do begin r := sqrt ( dx*dx + dy*dy); char_rot_w := dx / r; char_rot_h := dy / r; with gle_gcb^ do begin info1 := trunc(char_rot_w * 32768); info2 := trunc(char_rot_h * 32768); end; gle_text_dir ( gle_gcb ); end end; { set_text_rot } procedure set_char_size (width,height:real); { PURPOSE : To set the new character size } { save width and height, set flag so text xform is recalculated  } begin ck_system_init; ck_display_init; {if (width = 0.0) or (height = 0.0) then error (err_bad_parms);} with gcb^ do begin dgl_char_width := width; dgl_char_height := height; with gle_gcb^ do begin info1 := abs(trunc((width * xwtod_scale * 7 / 9) * 8)); info2 := abs(trunc((height * ywtod_scale * 9 / 15) * 8)); gle_char_size ( gle_gcb ); info1 := abs(trunc((width * xwtod_scale * 2 / 9) * 8)); info2 := abs(trunc((height * ywtod_scale * 6 / 15) * 8));  gle_text_spacing ( gle_gcb ); end; end end; { set_char_size } procedure set_echo_pos (wx,wy : real); { Purpose : To set the locator echo position } function between ( x1, p, x2 : real ) : boolean; { added for 2., 1 bug fix } begin between := (((x1 <= p) and ( p <= x2)) or ((x2 <= p) and ( p <= x1))); end; begin ck_system_init; ck_display_init; ck_locator_init; with gcb^ do with window_lim do begin { ck bounds } if (between (xmin,wx,xmax) and { 2.1 bug fix } between (ymin,wy,ymax)) then begin { set world coord echo pos } w_loc_echo_x := wx; w_loc_echo_y := wy; { convert to display units } convert_wtod (w_loc_echo_x,w_loc_echo_y,d_loc_echo_x,d_loc_echo_y); end { ignor call if outside window } end end; { set_echo_pos } procedure set_locator_lim ( lxmin,lxmax,lymin,lymax : real; var ierr : integer ); { Purpose : To set the locator echo position  } var txmin : real; txmax : real; tymin : real; tymax : real; begin ck_system_init; ck_locator_init; { input limits can only be changed if the input device is not the same physical device as the display  } with gcb^ do if not disp_eq_loc then begin { ck parms } if (lxmin < lxmax) and (lymin < lymax) then with gle_gcbi^ do with max_loc_lim do begin { convert limits form mil to locator cord } txmin := ((lxmin * input_res_x) + xmin); txmax := ((lxmax * input_res_x) + xmin); tymin := ((lymin * input_res_y) + ymin); tymax := ((lymax * input_res_y) + ymin); { make sure new logical imits are within the physical limits  } if (txmin >= xmin) and (txmax <= xmax + eight_diget_epsilon) and (tymin >= ymin) and (tymax <= ymax + eight_diget_epsilon) then begin { set new limits } locator_limits (txmin,txmax,tymin,tymax); ierr := 0; end else { bad limits } ierr := 2; end else { bad parms } ierr := 1; end else { locator and display are same device } ierr := 3; end; { set_locator_lim } procedure sample_locator( echo : integer; var rx,ry : real ); { Purpose : To sample the locator device } begin if loc_init then begin if disp_init then make_pic_current; call (gcb^.proc_sample_locator,echo,rx,ry); end else if system_init then error(err_loc_int) else error(err_sys_int); end; { sample_locator } procedure await_locator( echo : integer; var button : integer; var rx,ry : real ); { Purpose : To activate the locator, and wait for operator termination } var saved_pattern, saved_linewidth, saved_linestyle, saved_length, saved_mode, saved_drawing_mode : integer; begin ck_system_init; ck_locator_init; if disp_init then with gcb^,gle_gcb^ do  begin make_pic_current; saved_pattern := current_linestyle_pattern; saved_linewidth := current_linewidth; saved_linestyle := current_linestyle; saved_length := current_pattern_length; saved_mode := current_linestyle_mode;  saved_drawing_mode := current_drawing_mode; info1 := 0; info2 := 0; info3 := 0; info4 := -1; gle_linestyle ( gle_gcb ); info1 := 1; gle_linewidth ( gle_gcb ); call (proc_color,cursor_color); info1 := complement_mode; gle_define_drawing_mode ( gle_gcb ); end; call (gcb^.proc_await_locator,echo,button,rx,ry); if disp_init then begin with gcb^,gle_gcb^ do begin info1 := saved_linestyle; info2 := saved_length; info3 := saved_mode; info4 := saved_pattern; gle_linestyle ( gle_gcb ); info1 := saved_linewidth; gle_linewidth ( gle_gcb ); info1 := saved_drawing_mode; gle_define_drawing_mode ( gle_gcb ); call (proc_color,dgl_current_color); end; if echo > 1 then if not int_cp then move ( world_real_cpx, world_real_cpy ) else int_move ( world_int_cpx, world_int_cpy ); end; end; { await_locator } procedure display_term; { Purpose: To terminate the graphics display } begin ck_system_init; -  ck_display_init; with gcb^ do begin disp_init := false; disp_file_name := ''; disp_dev_adr := 0; { reset display limits to default } with init_display_lim do display_limits(xmin,xmax,ymin,ymax); if disp_eq_loc then with def_loc_lim do { locator limits no longer } locator_limits (xmin,xmax,ymin,ymax); { are effected by the display } disp_eq_loc := not loc_init; { if both disabled then they are equal } try call (gcb^.proc_color,0); gle_flush_buffer ( gle_gcb ); gle_get_p1p2 ( gle_gcb ); { Force read from device. This syncs the OS with buffered devices } gle_term(gle_gcb); recover { ignore timeout errors } if (escapecode <> -26) or (ioe_result <> 17) then escape(escapecode); end; end; { display_term } {rules for proc_locator_input/output_esc: o if it's your opcode you may set ierr appropriately o if it's not your opcode don't touch ierr o new output drivers should make a call to proc_locator_xxx_esc only after the display handler has had a chance at the opcode (and has set ierr to 1 if it wasn't processed by the display, or appropriate ierr number if the display did claim it) o opcodes to be handled by the display and those to be handled by the locator MUST NEVER have the same opcode number! It is recommended to use numbers with a 9 in the tens digit for locator opcodes. } procedure dummy_esc( opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer); begin end; {hili escs put here so can access locator_init, locator_term SFB 4/10/85} procedure hili_input_esc (opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer); begin if (opc = 4290) and (isize = 4) and (rsize = 2) and (ilist[1] >= 1) and (ilist[1] <= 7) then with loopcontrol^.loopdevices[ilist[1]].descrip do begin ilist[1] := id; ilist[2] := maxcountx; ilist[3] := maxcounty; ilist[4] := nbuttons; rlist[1] := counts/10.0; if not size16 then rlist[1] := rlist[1]/100.0; rlist[2] := rlist[1]; ierr := 0 end else if opc = 4290 then ierr := 4; {my opcode but bad parameters} end; procedure hili_output_esc(opc,isize,rsize : integer; anyvar ilist : gint_list; anyvar rlist : greal_list; var ierr : integer); var err : integer; {for call to locator_init} dev_adr : integer; myop : boolean; old_extend : integer; begin myop := (opc = 1090) or (opc = 1091); if myop and (isize = 1) and (rsize = 0) and (ilist[1] >= 0) then begin ierr := 0; dev_adr := gcb^.loc_dev_adr; {save locator address before losing it} if opc = 1091 then if dev_adr = 202 then {only relative locator} dvr_rec^.extend := ilist[1] {save kbd_terminator info in extend false = 0, true = other} else ierr := 1 else begin old_extend := dvr_rec^.extend; locator_term; {terminate previous locator so locator_init won't} dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask} locator_init(dev_adr,err); {and re-init using new devices to scale} dvr_rec^.extend := old_extend; if err <> 0 then {and check nothing went wrong} begin dvr_rec^.devices := 127; {re-enable all HIL locators in dvr because} ierr := 1 {we don't support for some reason, or all devices were deactivated} end; end; end  else if myop then ierr := 4; {bad parameters but my opcode} end; procedure locator_term; { Purpose: To terminate the locator device } begin ck_system_init; ck_locator_init; loc_init := false; with gcb^, gle_gcbi^ do begin if (input_handler_name = 'HILABS') or (input_handler_name = 'HILREL') then {4/9/85 SFB} begin proc_locator_input_esc := dummy_esc; proc_locator_output_esc := dummy_esc; end; disp_eq- _loc := not disp_init; { if both disabled then they are equal } loc_dev_adr := 0; end; { reset to default locator limits } with init_locator_lim do locator_limits (xmin,xmax,ymin,ymax); gle_input_term(gle_gcbi); end; { locator_term } procedure graphics_term; { Purpose: To terminate the graphics system } begin ck_system_init; { make sure all devices are terminated } if disp_init then display_term; if loc_init then locator_term; if dvr_rec <> nil then {enable all HPHIL locators in driver} dvr_rec^.devices := 127; { set system initialized flag to disabled } system_init := false; end; { graphics_term } procedure setup_display ( var ierr : integer); var i : integer; { Purpose: To set up display state after it has been initialized } begin with gcb^ do begin with gle_gcb^ do begin max_disp_lim.xmin := display_min_x; max_disp_lim.xmax := display_max_x; max_disp_lim.ymin := display_min_y; max_disp_lim.ymax := display_max_y; gle_get_p1p2 ( gle_gcb ); def_disp_lim.xmin := info1; def_disp_lim.xmax := info2; def_disp_lim.ymin := info3; def_disp_lim.ymax := info4; end; disp_init := true; disp_eq_loc := ((disp_dev_adr = loc_dev_adr) or ((disp_dev_adr = internal_display) and (loc_dev_adr = internal_locator))); { set up display limits } with def_disp_lim do display_limits(xmin,xmax,ymin,ymax); { set up default text size and rotation attributes } dgl_char_width := init_char_width_factor * abs (window_lim.xmax - window_lim.xmin); dgl_char_height := init_char_height_factor * abs (window_lim.ymax - window_lim.ymin); set_char_size ( dgl_char_width, dgl_char_height );  char_rot_w := init_char_rot_w; char_rot_h := init_char_rot_h; set_text_rot ( char_rot_w, char_rot_h ); { set up all attributes here } dgl_current_polygon_edge := true; dgl_current_polygon_crosshatch := false; dgl_current_polygon_linestyle := init_linestyle; dgl_current_polygon_style := 1; dgl_current_polygon_color := init_color; dgl_polygon_color_current := false; { color not set in gle } dgl_current_polygon_density := 0; dgl_current_polygon_angle := 0; set_timing ( dgl_current_timming_mode ); dgl_current_color := -1; { force calc of color } set_color(init_color); set_line_style(init_linestyle); set_line_width(init_linewidth); { init_cpy is in device units } cpx := init_cpx; cpy := init_cpy; with gle_gcb^ do begin marker_size_x := trunc(display_res_x * 2.5 + 0.5); { markers are 2.5 mm in size } marker_size_y := marker_size_x; info1 := marker_size_x; info2 := marker_size_y; gle_marker_size ( gle_gcb ); info1 := 1; gle_graphics_on_off ( gle_gcb ); { make sure graphics is on } end; end; end; { setup_display } procedure display_finit ( fname : gstring255; device_name : gstring255; control : integer; var ierr : integer ); { Purpose: To initialize the display device } var cnt : integer; begin ck_system_init; { make sure no display is currently enabled } if disp_init then display_term; if strlen(strrtrim(strltrim(device_name))) <> 0 then with gle_gcb^ do begin device_info := addr(fname[1]); device_info_char_count := strlen(fname); spooling := 1; display_name := ' '; display_name_char_count := min(strlen(device_name),6); for cnt := 1 to display_name_char_count do display_name [cnt] := device_name[cnt]; info1 := control; info2 := 0; { config DGL stuff } configure_gle (gle_gcb); ierr := error_return; end else ierr := 2; if ierr = 0 then try with gcb^ do begin disp_dev_adr := -1; { indicate file name } disp_file_name := fname; setup_display ( ierr ); end; recover begin if escapecode = -20 then escape(escapecode); { ignor all errors except stop key } ierr := 2; end .  else ierr := 2; end; { display_finit } procedure display_init ( dev_adr : integer; control : integer; var ierr : integer ); { Purpose: To initialize the display device } var s : string[10]; cnt : integer; begin ck_system_init; { make sure no display is currently enabled } if disp_init then display_term; with gle_gcb^ do begin s := ''; strwrite(s,1,cnt,dev_adr:0); device_info_char_count := strlen(s); device_info := addr(s[1]); spooling := 0; info1 := control; info2 := 0; { config DGL stuff } configure_gle (gle_gcb); ierr := error_return; end; if ierr = 0 then try with gcb^ do begin disp_dev_adr := dev_adr; disp_file_name := ''; end; setup_display ( ierr ); if gle_gcb^.complement_support = 1 then gle_gcb^.cursor := dgl_cursor; recover begin if escapecode = -20 then escape(escapecode); { ignor all errors exect stop key } ierr := 2;  end else ierr := 2; end; { display_init } procedure locator_init ( dev_adr : integer; var ierr : integer ); { Purpose: To initialize the locator device } var s : string[10]; i : integer; begin ck_system_init; { make sure no locator is enabled } if loc_init then locator_term; { try to init a locator } if disp_init then make_pic_current; with gcb^,gle_gcbi^ do begin s := ''; strwrite(s,1,i,dev_adr:0); device_info_char_count := strlen(s); device_info := addr(s[1]); info1 := 0; { init sample loc value } info2 := 0; if disp_init then {SFB 3/27/85} {tell gle_init_knob_input whether} begin info3 := gle_gcb^.pallette; {color or mono display} input_max_x := gle_gcb^.display_max_x; {for DGL_REL SFB 10-27-86 } input_max_y := gle_gcb^.display_max_y; {for DGL_REL SFB 10-27-86 } end else begin info3 := 0; {or display not initialized} input_max_x := 32767; {for DGL_REL SFB 10-27-86 } input_max_y := 32767; {for DGL_REL SFB 10-27-86 } end; configure_input_gle ( gle_gcbi ); ierr := error_return; if ierr = 0 then begin loc_init := true; loc_dev_adr := dev_adr; with gle_gcbi^,gcb^.max_loc_lim do begin xmin := input_min_x; xmax := input_max_x; ymin := input_min_y; ymax := input_max_y; end; gle_get_input_p1p2 ( gle_gcbi ); with gle_gcbi^,gcb^,gcb^.def_loc_lim do begin xmin := info1; xmax := info2; ymin := info3; ymax := info4; end; disp_eq_loc := disp_init and ((disp_dev_adr = loc_dev_adr) or ((disp_dev_adr = internal_display) and (loc_dev_adr = internal_locator))); { If locator is not the same physical device as the graphics display, then the locator limits are set to the default locator limits. If the locator is the same device, then the locator limits are set to the current display limits. } with gcb^ do begin if disp_eq_loc then with cur_disp_lim do locator_limits (xmin,xmax,ymin,ymax) else with def_loc_lim do locator_limits (xmin,xmax,ymin,ymax); end; if (input_handler_name = 'HILABS') or (input_handler_name = 'HILREL') then {SFB 4/9/85} begin proc_locator_output_esc := hili_output_esc; proc_locator_input_esc := hili_input_esc; end; end else ierr := 2; end; end; { locator_init } procedure graphics_init; { Purpose: To initialize the graphics system } begin { make sure the system is not already init } if system_init then graphics_term; { set state flags } system_init := true; disp_init := false; loc_init := false; { get storage space -- changed from dynamic to global 2/84 BDS } gcb := addr(gcb_space); { DGL high level storage } gle_gcb := addr(gle_gcb_space); { display output device } gle_init_gc. b ( gle_gcb ); gle_gcbi := addr(gle_gcbi_space); { locator input device } gle_init_input_gcb ( gle_gcbi ); gle_knob_echo_gcb := addr(gle_knob_echo_gcb_space); {knob echo output device (internal crt)} gle_init_gcb ( gle_knob_echo_gcb ); { kbdlangjumper is imported from sysglobales. Kata becomes true if the kata keyboard is instaled } if kbdlang = katakana_kbd then gle_gcb^.kata := 1 else gle_gcb^.kata := 0; { set up defaults } with gcb^ do begin { When first inited that display and locator are the same device } disp_eq_loc := true; disp_dev_adr := init_dev_adr; disp_file_name := ''; loc_dev_adr := init_dev_adr; window_lim := init_window;  aspect_ratio := init_aspect; cur_vir_lim := init_vir_lim; viewport_lim := init_viewport; { setup the default display/ locator limits to some large number } with init_display_lim do display_limits ( xmin, xmax, ymin, ymax );  with init_locator_lim do locator_limits ( xmin, xmax, ymin, ymax ); { explicitly set the cp to init_value } cpx := init_cpx; cpy := init_cpy; int_cp := true; world_int_cpx := init_cpx; world_int_cpy := init_cpy;  { set up default text size and rotation attributes } dgl_char_width := init_char_width; dgl_char_height := init_char_height; char_rot_w := init_char_rot_w; char_rot_h := init_char_rot_h; { set flag, indicating that the text xform needs to be recalulated } calc_text_xform := true; dgl_current_color := init_color; dgl_current_linestyle := init_linestyle; dgl_current_linewidth := init_linewidth; dgl_current_timming_mode := init_timming_mode; cursor_color := init_color; disp_just := centered; display_echo_mult := 1; graphics_error := 0; number_polygon_styles := default_poly_table_size; color_table_size := default_color_table_size; dgl_current_polygon_color := 1; dgl_current_polygon_linestyle := 1; dgl_current_polygon_density := 0; dgl_current_polygon_angle := 90; dgl_current_polygon_edge := true; dgl_current_polygon_crosshatch := false; dgl_current_polygon_style := 1; dgl_current_color_model := 1; proc_locator_output_esc := dummy_esc; {SFB 4/9/85} proc_locator_input_esc := dummy_esc; {SFB 4/9/85} end; if dvr_rec <> nil then {enable all HPHIL locators in driver} dvr_rec^.devices := 127; end; { graphics_init } end. {module DGL_LIB} $LIST ON$  { This include file specifies range checking, debug and other compiler options for the graphics library } $debug OFF$ $range OFF$ $copyright 'COPYRIGHT HEWLETT-PACKARD COMPANY, 1982, 1991'$ $FLOAT_HDW OFF$   * * Graphics Low End * * Module = Gle_aras_out * Programer = DAC, BJS * Date = 9-30-82 * * Purpose : To provide low-level raster routines. * * Rev history * * Created - 9-30-82 * Modified - 6-28-83 BJS Changed module name to not conflict with * the pascal name * -12-07-83 BDS Added fixes for cursor bug * -01-30-84 BJS Speedup fix for set_color, set_line_style * -02-17-84 BDS Added support for gator for P/ ascal 3.0 * -05-01-85 SFB Added support for bobcat/gatorbox * -05-29-91 CFB Added support for WOODCUT * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * Change error routine err_esc for every OS transport * nosyms mname gle_aras_out src module GLE_ARAS_OUT; src import GLE_TYPES; src export src procedure rgcbinit ( GCB : graphics_control_block_ptr ); src procedure rgraphics_on_off ( GCB : graphics_control_block_ptr ); src procedure rclear ( GCB : graphics_control_block_ptr ); src procedure rmove ( GCB : graphics_control_block_ptr ); src procedure rdraw ( GCB : graphics_control_block_ptr ); src procedure rdefine_drawing_mode ( GCB : graphics_control_block_ptr); src procedure rlinestyle ( GCB : graphics_control_block_ptr); src procedure rcursor ( GCB : graphics_control_block_ptr); src procedure rset_color ( GCB : graphics_control_block_ptr);  src procedure rpolygon ( GCB : graphics_control_block_ptr ); src procedure rget_p1p2 ( GCB : graphics_control_block_ptr ); src procedure rget_raster ( GCB : graphics_control_block_ptr ); src procedure rfill_index_color ( GCB : graphics_control_block_ptr ); src procedure rawait_blanking ( GCB : graphics_control_block_ptr ); src procedure store_dit ( GCB : graphics_control_block_ptr ); src procedure set_6845s ( GCB : graphics_control_block_ptr ); src procedure setgboxcmap( GCB : graphics_control_block_ptr); src procedure set_nereid( GCB : graphics_control_block_ptr); src procedure set_wood_cmap( GCB : graphics_control_block_ptr); src procedure dither_to_pattregs( GCB : graphics_control_block_ptr); src end; rorg 0 refa sysglobals refa sysdevs refa gle_asclip_clipping refa gle_types refa delay_timer refa asm_flush_icache {3/25/85 SFB} lmode sysglobals  lmode sysdevs lmode gle_asclip_clipping lmode gle_types lmode delay_timer lmode asm_flush_icache {3/25/85 SFB} def gle_aras_out_rgcbinit def gle_aras_out_rgraphics_on_off def gle_aras_out_rclear def gle_aras_out_rmove def gle_aras_out_rdraw def gle_aras_out_rdefine_drawing_mode def gle_aras_out_rset_color def gle_aras_out_rlinestyle def gle_aras_out_rpolygon def gle_aras_out_rget_raster def gle_aras_out_rcursor def gle_aras_out_rfill_index_color def gle_aras_out_rget_p1p2 def gle_aras_out_rawait_blanking def gle_aras_out_store_dit def gle_aras_out_set_6845s def gle_aras_out_setgboxcmap def gle_aras_out_set_nereid def gle_aras_out_set_wood_cmap CFB 12JUN91 def gle_aras_out_dither_to_pattregs SFB 3/8/88 def gle_aras_out_gle_aras_out def fgator  for debug only def hv50 " def hv52 " DEF FBOBCAT " DEF VEC6 DEF BUILD_PEN DEF SET_PEN * * def gdump_exp * def gload_proc * def gstore_proc * ADDR1 equ 0 ADDR2 equ 4 ADDR3 equ 8 AREA_DRAW_MODE equ 74 BLU_INTENSITY equ 52 BYTESPERLINE equ 42 CMAP_ADDRESS equ 1890 CPEN equ 82 CURSOR_X /  equ 70 CURSOR_Y equ 72 DEVICEADDRESS equ 16 DEVICETYPE equ 14 DITHER_PATTERN equ 54 GRN_INTENSITY equ 50 GSPACING equ 40 HARD_XMAX equ 44 HARD_YMAX equ 46 INDEX equ 110 LINEPATTERN equ 78 MONITORTYPE equ 20 N3 equ 12 N_GLINES equ 38 OLDPATTERN equ 84 PEN_DRAW_MODE equ 76 * PEN_NUMBER equ 80 SEE PEN_NUM PEN_NUM equ 80 PLANE1_ADDR equ 22 PLANE1_OFFSET equ 26 PLANE2_OFFSET equ 30 PLANE3_OFFSET equ 34 RED_INTENSITY equ 48 REPEATCOUNT equ 108 REPEATRATE equ 106 RGLTEMP1 equ 86 RGLTEMP2 equ 90 RGLTEMP3 equ 94 RGLTEMP4 equ 98 RGLTEMP5 equ 102 SOFTVEC equ 114 SYSTEM_CMAP equ 354 * addr1 equ 0 integer * addr2 equ addr1+4 integer * addr3 equ addr2+4 integer * n3 equ addr3+4 shortint * devicetype equ n3+2 shortint * deviceaddress equ devicetype+2 integer only used on moonunit * monitortype equ deviceaddress+4 shortint "" "" * plane1_addr equ monitortype+2 integer * plane1_offset  equ plane1_addr+4 integer * plane2_offset equ plane1_offset+4 integer * plane3_offset equ plane2_offset+4 integer * n_glines equ plane3_offset+4 shortint * gspacing equ n_glines+2 shortint * bytesperline equ gspacing+2 shortint * hard_xmax equ bytesperline+2 shortint * hard_ymax equ hard_xmax+2 shortint * red_intensity equ hard_ymax+2 shortint * grn_intensity equ red_intensity+2 shortint * blu_intensity equ grn_intensity+2 shortint * dither_pattern equ blu_intensity+2 16 bytes * cursor_x equ dither_pattern+16 shortint * cursor_y equ cursor_x+2 shortint * area_draw_mode equ cursor_y+2 shortint * pen_draw_mode equ area_draw_mode+2 shortint * linepattern equ pen_draw_mode+2 shortint * pen_num equ linepattern+2 shortint * cpen equ pen_num+2 shortint * oldpattern equ cpen+2 shortint * rgltemp1 equ oldpattern+2 integer * rgltemp2 equ rgltemp1+4 integer * rgltemp3 equ rgltemp2+4 integer * rgltemp4 equ rgltemp3+4 integer * rgltemp5 equ rgltemp4+4 integer * repeatrate equ rgltemp5+4 shortint * repeatcount equ repeatrate+2 shortint * index equ repeatcount+2 integer * softvec  equ index+4 240 bytes of instructions * system_cmap equ softvec+240 * * brightness_seq equ system_cmap+1536 removed for 3.1 implementation * * count equ brightness_seq+512 SFB 12/14/84 * cmap_address equ system_cmap+1536 count+512 rule equ gle_types-4 window equ gle_types-8 status equ gle_types-20 stat equ $4001 charcount equ rgltemp1 t1 equ rgltemp1 t2 equ rgltemp2 t3  equ rgltemp3 t4 equ rgltemp4 t5 equ rgltemp5 gle_gcb equ a4 rgl_gcb equ a6 zero equ d0 one equ d1 no equ d0 yes equ d1 packed_pixel_odd_byte_display equ 0 packed_pixel_display equ 1 packed_pixel_3_plane_display equ 2 byte_per_pixel_display equ 3 gator_display equ 4 gatorbox_display equ 5 bobcat_display equ 6 bobcat_lores_display equ 7 catseye_display equ 8 catseye_hrx_display equ 9 woodcut_vga_display equ 10 CFB - 31MAY91 woodcut_med_display equ 11 CFB - 31MAY91 woo0 dcut_hrx_display equ 12 CFB - 31MAY91 woodcut_vgam_display equ 13 CFB - 30JUL91 woodcut_hrxm_display equ 14 CFB - 30JUL91 rrcopy  equ sysdevs-92 gle_types global replrulecopy wwcopy equ sysdevs-94 gle_types global widthcopy writecopy equ sysdevs-96 gle_types global writeprotect controladdr equ gle_types-30 gle_types global ID ROM base hrm_tertiary equ 7 unique to CATSEYE HRM {SFB} tert_off equ $15 within ID ROM initoffset equ $23 within ID ROM cmapidoff  equ $57 within ID ROM cmapinitoff equ $3F within ID ROM blinkrega equ $6001 gatorbox blinkregb equ $6005 gatorbox writereg equ $6008 gatorbox sox equ $40f2 bobcat source x soy equ $40f6 bobcat source y dox equ $40fa bobcat dest x doy equ $40fe  bobcat dest y bobh equ $4106 bobcat height bobw equ $4102 bobcat width bobwr equ $40ee bobcat window repl rule bobwm equ $409c  bobcat window move start curson equ $40ac bobcat cursor enable SFB 6/11/85 pattregs equ $4400 CATSEYE pattern register base SFB fben1 equ $4500 frame buffer enable in upper byte SFB trr equ $450c upper byte=Three Operand Repl Rule SFB trr_enable equ $4512 bit 8 of word selects trr/wrr SFB catseye_status equ $4800 catseye status in lower byte SFB * unique WOODCUT register definitions CFB 10JUN91 blueregimage equ $00060610 dacimagewrite equ $00060202 include ASM_TYPES * * page * * utility subroutines * rorg 0 rts movem.l old_a5(gle_gcb),a5-a6 rts err_esc movem.l old_a5(gle_gcb),a5-a6 move d0,sysglobals-2(a5) trap #10 int_ovflow move #-4,d0 integer overflow bra err_esc page * * procedure gcbinit(gcb: graphics_control_block_ptr); * gle_aras_out_rgcbinit equ * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = ptr to device rec move.l info_ptr1(gle_gcb),plane1_addr(rgl_gcb) move.l info_ptr2(gle_gcb),plane1_offset(rgl_gcb) moveq #0,d0 moveq #1,d1 move.w yes,complement_support(gle_gcb) complement := true move.w yes,non_dominant_support(gle_gcb) move.w yes,erase_support(gle_gcb) move.w yes,dither_support(gle_gcb) move.w yes,polygon_support(gle_gcb) move.w yes,polygon_fill_factor(gle_gcb) move.w yes,polygon_solid_fill(gle_gcb) move.w yes,background(gle_gcb) move.w #-1,cont_linestyles(gle_gcb) move.w zero,vect_linestyles(gle_gcb) move.w one,linewidths(gle_gcb) move.w #-1,char_sizes(gle_gcb) move.l zero,current_pos_x(gle_gcb) move.l zero,current_pos_y(gle_gcb) move.w no,current_drawing_mode(gle_gcb) move.w #-1,current_linestyle_pattern(gle_gcb) move.w zero,current_cursor_state(gle_gcb) move.l zero,current_cursor_x(gle_gcb) move.l zero,current_cursor_y(gle_gcb) * cmpi.w #3,info1+2(gle_gcb) ck for device * blt.s init16 9816 or 9826 * beq.s init36 9836A * cmpi.w #5,info1+2(gle_gcb) * 0  blt init36c 9836C * bgt.s initGatbw Gator BW move.w info1+2(gle_gcb),d2 compute jump table entry asl.w #1,d2 for dev dep initialize  move.w base_rgl(d2),d2 jmp init_rgl(d2) jump to dev dep initialize base_rgl equ *-2 "virtual" entry #0 of table init_rgl equ * dev dep initialize jump table dc.w init16-init_rgl dc.w init16-init_rgl dc.w init36-init_rgl dc.w init36c-init_rgl dc.w init27A-init_rgl dc.w initGatbw-init_rgl dc.w initgbox-init_rgl dc.w initbobcat-init_rgl dc.w  initbobcatlores-init_rgl dc.w initcatseye-init_rgl dc.w initcatseye_hrx-init_rgl dc.w initwoodcut_vga-init_rgl CFB - 31MAY91 dc.w initwoodcut_med-init_rgl CFB - 31MAY91 dc.w  initwoodcut_hrx-init_rgl CFB - 31MAY91 dc.w initwoodcut_vgam-init_rgl CFB - 30JUL91 dc.w initwoodcut_hrxm-init_rgl CFB - 30JUL91 init27A move.w #packed_pixel_3_plane_display,devicetype(rgl_gcb) 98627a move.w info3+2(gle_gcb),monitortype(rgl_gcb) move.l info2(gle_gcb),deviceaddress(rgl_gcb) move.w no,color_map_support(gle_gcb) move.w yes,redef_background(gle_gcb) move.l #7,pallette(gle_gcb)  move.l #7,gamut(gle_gcb) bra gen_init init16 move.w #packed_pixel_odd_byte_display,devicetype(rgl_gcb) bra initcom initGatbw move.w #gator_display,devicetype(rgl_gcb) bra initcom init36 move.w #packed_pixel_display,devicetype(rgl_gcb) initcom move.w no,color_map_support(gle_gcb) move.w yes,redef_background(gle_gcb) move.l one,pallette(gle_gcb) move.l one,gamut(gle_gcb) redone for bobcat B/W in GLE_RGL bra gen_init initgbox move.w #gatorbox_display,devicetype(rgl_gcb) move.l info2(gle_gcb),deviceaddress(rgl_gcb) move.l info3(gle_gcb),cmap_address(rgl_gcb) initcmapinfo equ * move.w yes,color_map_support(gle_gcb) move.w yes,redef_background(gle_gcb) move.l #16777216,pallette(gle_gcb) R,G,B each have 8 bits * can't find gamut in rgcbinit for gatorbox or bobcat; done in setup routine * in GLE_RGL !!!!!!! cmpi.w #12,devicetype(rgl_gcb) ck for MONO WOODCUT CFB - 9AUG91 ble  gen_init CFB - 9AUG91 move.l #256,pallette(gle_gcb) G only has 8 bits CFB - 9AUG91 bra gen_init initwoodcut_vga equ * CFB - 31MAY91 move.w #woodcut_vga_display,devicetype(rgl_gcb) CFB - 31MAY91 bra.s initwoodcutgen CFB - 31MAY91 initwoodcut_med equ * CFB - 31MAY91 move.w #woodcut_med_display,devicetype(rgl_gcb) CFB - 31MAY91 bra.s initwoodcutgen CFB - 31MAY91 initwoodcut_hrx equ * CFB - 31MAY91 move.w #woodcut_hrx_display,devicetype(rgl_gcb) CFB - 31MAY91 bra.s initwoodcutgen CFB - 31MAY91 initwoodcut_vgam equ * CFB - 30JUL91 move.w #woodcut_vgam_display,devicetype(rgl_gcb) CFB - 30JUL91 bra.s initwoodcutgen CFB - 30JUL91 initwoodcut_hrxm equ * CFB - 30JUL91 move.w #woodcut_hrxm_display,devicetype(rgl_gcb) CFB - 30JUL91 bra.s initwoodcutgen  CFB - 30JUL91 initcatseye equ * move.w #catseye_display,devicetype(rgl_gcb) bra.s initbobcatgen initcatseye_hrx equ * move.w #catseye_hrx_display,devicetype(rgl_gcb) bra.s initbobcatgen initbobcatlores equ1  * move.w #bobcat_lores_display,devicetype(rgl_gcb) bra.s initbobcatgen initbobcat equ * move.w #bobcat_display,devicetype(rgl_gcb) * {SFB} hacked to allow HRM CATSEYE to be known as mono disply to DGL, * and initialize GCB for same HRM CATSEYE IS "mono" but has cmap other * CATSEYE/BOBCAT are color or have no cmap signal "mono" for HRM, and send * back to gle_rgl initbobcatgen equ * movea.l info2(gle_gcb),a0 move.l a0,deviceaddress(rgl_gcb) cmpi.b #hrm_tertiary,tert_off(a0) bne.s get_cmap_info move.l #0,info3(gle_gcb) get_cmap_info equ * move.l info3(gle_gcb),cmap_address(rgl_gcb) beq initcom bra initcmapinfo initwoodcutgen equ * movea.l info2(gle_gcb),a0 move.l a0,deviceaddress(rgl_gcb) move.l #0,info3(gle_gcb) move.l info3(gle_gcb),cmap_address(rgl_gcb) bra initcmapinfo init36c move.w #byte_per_pixel_display,devicetype(rgl_gcb) move.l info2(gle_gcb),deviceaddress(rgl_gcb)  move.l info3(gle_gcb),cmap_address(rgl_gcb) move.w yes,color_map_support(gle_gcb) move.w yes,redef_background(gle_gcb) move.l #4095,pallette(gle_gcb) move.l #15,gamut(gle_gcb) gen_init move devicetype(rgl_gcb),d0 choose frame buf info init block move d0,d2 cmpi.w #7,devicetype(rgl_gcb) ck for bobcatlores bne.s ckbitmap move #5,d0 bobcatlores init block is #5 bra.s gen1 ckbitmap equ * cmpi.w #6,info1+2(gle_gcb) ck for Gator/gbox/bobcathires blt.s gen1 cmpi.w #11,info1+2(gle_gcb) ck for Catseye_hrx beq.s adjust_catseye_hrx cmpi.w #10,devicetype(rgl_gcb) ck for WOODCUT CFB - 24JUL91 bge.s adjust_woodcut CFB - 31MAY91 move #4,d0 use initialize block 4 for Bobcat clones bra.s gen1 adjust_woodcut equ * CFB - 31MAY91 move devicetype(rgl_gcb),d0 CFB - 31MAY91 subq #3,d0 convert 10-12 to 7-9 CFB - 31MAY91 cmpi.w #12,devicetype(rgl_gcb) ck for MONO WOODCUT CFB - 30JUL91 ble.s gen1 CFB - 30JUL91 subq #3,d0 convert 13-14 to 7-8 CFB - 30JUL91 cmpi.w #7,d0 VGA? CFB - 11OCT91 beq.s gen1 CFB - 11OCT91 addq #1,d0  Hrx? convert 8 to 9 CFB - 11OCT91 bra.s gen1 CFB - 31MAY91 adjust_catseye_hrx equ * move #6,d0 hrx block index *  except LCC * of gator/gatorbox/bobcathires * cmpi.w #7,info1+2(gle_gcb) ck for Gator Color * bne.s gen1 * move #5,d0 gen1 mulu #init1-init_table,d0 calc offset into init_table movea.l d0,a0 lea init_table(a0),a0 lea plane2_offset(rgl_gcb),a1 move.l (a0)+,(a1)+ and offsets to display table move.l (a0)+,(a1)+ moveq #4,d1 * cmp #2,d2  bra initloop init_table dc.l 0 plane2_offset ( not used ) {9816A} dc.l 0 plane3_offset ( not used ) dc 300 n_glines dc 2 gspacing dc 100 bytesperline dc 399 hard_xmax dc 299 hard_ymax init1 dc.l 0 plane2_offset ( not used ) {9836a} dc.l 0 plane3_offset ( not used ) dc 390 n_glines dc 1 gspacing dc 64 bytesperline dc 511 hard_xmax dc 389 hard_ymax init2 dc.l $8000 plane2_offset {Moonunit} dc.l $10000 plane3_offset dc 390 n_glines dc 1 gspacing dc 64 by1 tesperline dc 511 hard_xmax dc 389 hard_ymax init3 dc.l 0 not used {9836c} dc.l 0 not used dc 390 n_glines dc 1 gspacing dc 512 bytesperline dc 511 hard_xmax dc 389 hard_ymax init4 dc.l 0 not used {Gator/gatorbox/bobcathires} dc.l 0 not used dc 752 n_glines dc 1 gspacing dc 1024 bytesperline dc 1023 hard_xmax dc 751 hard_ymax init5 dc.l 0 not used {bobcat lores block} dc.l 0 not used dc 385 n_glines dc 1 gspacing dc 1024 bytesperline dc 511 hard_xmax dc 384 hard_ymax init6 dc.l 0 not used {catseye_hrx block} dc.l 0 not used dc 1000 n_glines only 1000 because we use 50 alpha lines *  at 10 scan lines each, and don't offset * alpha the 4 "wasted" pixels as we do on * low-res Bobcat dc 1 gspacing dc 2048 bytesperline dc 1279 hard_xmax dc 999 hard_ymax init7 dc.l 0 not used {woodcut_vga block} CFB - 31MAY91 dc.l 0 not used CFB - 31MAY91 dc 464 n_glines  CFB - 31MAY91 dc 1 gspacing CFB - 31MAY91 dc 2048 bytesperline all WOODCUTS are 2K CFB - 31MAY91 dc 639 hard_xmax CFB - 31MAY91 dc 463 hard_ymax CFB - 31MAY91 init8 dc.l 0 not used {woodcut_med block} CFB - 31MAY91 dc.l 0 not used CFB - 31MAY91 dc 752  n_glines CFB - 31MAY91 dc 1 gspacing CFB - 31MAY91 dc 2048 bytesperline all WOODCUTS are 2K CFB - 31MAY91 dc 1023 hard_xmax  CFB - 31MAY91 dc 751 hard_ymax CFB - 31MAY91 init9 dc.l 0 not used {woodcut_hrx block} CFB - 31MAY91 dc.l 0 not used CFB - 31MAY91 dc 1000 n_glines CFB - 31MAY91 dc 1 gspacing CFB - 31MAY91 dc 2048 bytesperline all WOODCUTS are 2K CFB - 31MAY91 dc 1279 hard_xmax  CFB - 31MAY91 dc 999 hard_ymax CFB - 31MAY91 initloop move (a0)+,(a1)+ copy some stuff from init_table dbra d1,initloop moveq #16,d0 move d0,(a1)+  set default fill colors move d0,(a1)+ move d0,(a1)+ move #$FFFF,current_linestyle_pattern(gle_gcb) clr oldpattern(rgl_gcb) move #1,repeatcount(rgl_gcb) move #1,repeatrate(rgl_gcb) bsr build_pen | create 1st vec template * if the device is a 98627 or 98627 gload image, n_glines must be * calculated. if monitor type = (1,2,6) then n_glines and the * other parameters associated with variable height (hard_ymax, *  etc) are already correct. cmpi.b #2,devicetype+1(rgl_gcb) bne set_pen not a 98627 style image cmpi #3,monitortype(rgl_gcb) blt init_regs n_glines is already set up beq.s init474  cmpi #6,monitortype(rgl_gcb) bge init_regs n_glines is already set up init512 move #512,n_glines(rgl_gcb) move #511,hard_ymax(rgl_gcb) bra init_regs init474 move #474,n_glines(rgl_gcb) move 2  #473,hard_ymax(rgl_gcb) init_regs move monitortype(rgl_gcb),d0 cmp #1,d0 blt set_pen make sure 1 <= monitortype <= 6 cmp #6,d0 to prevent hardware damage bgt set_pen lsl #4,d0 calculate offset into lea usstd(d0),a0 setup table for 6845 movea.l deviceaddress(rgl_gcb),a1 moveq #15,d0 setuploop move.b d0,$10(a1) select a register move.b -(a0),$12(a1) write a value dbra d0,setuploop bra set_pen usstd dc.b 41 horizontal total dc.b 32 horizontal displayed dc.b 34 horizontal sync position dc.b 3 horizontal sync width dc.b 50 vertical total dc.b 5 vertical total adjust dc.b 49 vertical displayed dc.b 49 vertical sync position dc.b 0 interlace mode dc.b 7 max scan line address dc.b 0  cursor start (don't care) dc.b 0 cursor end (don't care) dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) eurostd dc.b 41 horizontal total dc.b 32 horizontal displayed dc.b 34 horizontal sync position dc.b 3 horizontal sync width dc.b 61 vertical total dc.b 0 vertical total adjust dc.b 49 vertical displayed dc.b 55 vertical sync position dc.b 0 interlace mode dc.b 7 max scan line address dc.b 0 cursor start (don't care) dc.b 0 cursor end (don't care)  dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) ustv dc.b 39 horizontal total dc.b 32 horizontal displayed dc.b 34 horizontal sync position dc.b 3 horizontal sync width dc.b 31 vertical total dc.b 6 vertical total adjust dc.b 30 vertical displayed dc.b 30 vertical sync position dc.b 3 interlace mode dc.b 7 max scan line address dc.b 0 cursor start (don't care) dc.b 0 cursor end (don't care) dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) eurotv dc.b 39 horizontal total dc.b 32 horizontal displayed dc.b 34 horizontal sync position dc.b 3 horizontal sync width dc.b 38 vertical total dc.b 0 vertical total adjust dc.b 32 vertical displayed dc.b 35 vertical sync position dc.b 3 interlace mode dc.b 7 max scan line address dc.b 0 cursor start (don't care) dc.b 0 cursor end (don't care) dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) hires dc.b 41 horizontal total dc.b 32 horizontal displayed dc.b 34 horizontal sync position dc.b 3 horizontal sync width dc.b 65 vertical total dc.b 5 vertical total adjust dc.b 64 vertical displayed dc.b 64 vertical sync position dc.b 0 interlace mode dc.b 7 max scan line address dc.b 0 cursor start (don't care) dc.b 0 cursor end (don't care) dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) jvc dc.b 44 horizontal total2  dc.b 32 horizontal displayed dc.b 36 horizontal sync position dc.b 3 horizontal sync width dc.b 56 vertical total dc.b 5 vertical total adjust dc.b 49 vertical displayed dc.b  49 vertical sync position dc.b 0 interlace mode dc.b 7 max scan line address dc.b 0 cursor start (don't care) dc.b 0 cursor end (don't care) dc.b 0 start address (upper byte) dc.b 0 start address (lower byte) dc.b 0 cursor h (don't care) dc.b 0 cursor l (don't care) page * * procedure store_dit(gcb:anyptr); * gle_aras_out_store_dit equ * movea.l 4(sp),gle_gcb  a4 = addr of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device_rec_ptr loopstA movea.l status(a5),a0 btst #7,1(a0) beq.s loopstA moveq #3,d0 move.w d0,rrcopy(a5) update current repl. rule movea.l rule(a5),a0 setup repl. rule move.w d0,(a0) movea.l plane1_addr(rgl_gcb),a1 ptr to address  movea.l (a1),a1 adda.l plane1_offset(rgl_gcb),a1 upper right display address adda.l #$0FF000,a1 a1 points to 3rd to last line move.l dither_pattern(rgl_gcb),(a1) move.l dither_pattern+4(rgl_gcb),$400(a1) move.l dither_pattern+8(rgl_gcb),$800(a1) move.l dither_pattern+12(rgl_gcb),$C00(a1) loopstB movea.l status(a5),a0 btst #7,1(a0) beq.s loopstB moveq #$83,d0 move.w d0,rrcopy(a5) update current repl. rule movea.l rule(a5),a0 set up replacement rule move.w d0,(a0) moveq #3,d0 loopst1 moveq #4,d1 loopst2 move d1,d2 loopstC movea.l status(a5),a0 btst #7,1(a0) beq.s loopstC  neg d2 move.w d2,wwcopy(a5) update current window width movea.l window(a5),a0 set window width move.w d2,(a0) move.b (a1),0(a1,d1) move some bytes lsl #1,d1  d1=2*d1 loopst3 movea.l status(a5),a0 btst #7,1(a0) beq.s loopst3 cmpi #512,d1 ble.s loopst2 adda #$400,a1 bump a1 to next line dbra d0,loopst1 loopst4 movea.l status(a5),a0 btst #7,1(a0) beq.s loopst4 moveq #3,d0 Restore rep rule move.w d0,rrcopy(a5) update current repl. rule movea.l rule(a5),a0 set up replacement rule bra rts * * procedure set_6845s(gcb:anyptr); * set up gator 6845's from Gator ROM * gle_aras_out_set_6845s equ * movea.l 4(sp),gle_gcb a4 = addr of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device_rec_ptr cmpi.b #5,devicetype+1(rgl_gcb) gatorbox/bobcat both use std bge std_graphics_rom graphics ID ROM gator_rom equ * movea.l controladdr(a5),a0 get pointer to ROM start moveq #0,d0 moveq #0,d1 move.b stat(a0),d0 get status reg again lsr.b #2,d0 get monitor type bits and.b #12,d0  move.b initoffset(a0,d0.w),d1 get MSB of info addr offset lsl.w #8,d1 move.b initoffset+2(a0,d0.w),d1 get LSB of info addr offset movea.l a0,a1 make copy of ROM start addr adda d1,a1 a1 points to init info now jsr ginitblock call the initialization routine bra rts that's all for gator * ginitblock is common code for both gator ROM, and gatorbox/bobcat ROM ginitblock moveq #0,d1 3  clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize movep 4(a1),d1 form destination offset add.l a0,d1 d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a3 a3 points to destination btst #0,(a1) added for bit_test SFB 3 Mar '88 bne.s bit_test see new Graphics ID ROM definition SFB ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a3)+ move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1 based on control byte  addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1) adjust data pointer beq.s ginit2 to point to next init block finish_block equ * point to next block SFB addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock  do the initialize bit_test move.b 2(a2),d2 bit number to test SFB and.b #$0f,d2 ensure bitnum #0..#15 SFB tst.b (a2) compare bit to 0 or to 1? SFB bne test_for_1  SFB test_for_0 equ * wait for 0 in bit d2 of d3 SFB move.w (a3),d3 status word to test SFB btst d2,d3 ready? SFB bne test_for_0 bra finish_block  and got to next block SFB test_for_1 equ * wait for 0 in bit d2 of d3 SFB move.w (a3),d3 status word to test SFB btst d2,d3 ready? SFB beq test_for_1 bra finish_block and got to next block SFB ginitdone rts 3.1E BUGFIX SFB 6/13/85 std_graphics_rom equ * movea.l controladdr(a5),a0 get pointer to ROM start movep initoffset(a0),d1 form pointer to init block 0 movea.l a0,a1 make copy of ROM start addr adda d1,a1 a1 points to init info now * bobcat CURSON save/restore added SFB 6/11/85 cmpi.b #6,devicetype+1(rgl_gcb) for bobcat save CURSON register blt.s do_ginit move.b curson(a0),rgltemp1(rgl_gcb) save value of CURSON do_ginit jsr ginitblock call the initialization routine cmpi.b #6,devicetype+1(rgl_gcb) for bobcat restore CURSON blt.s init_cmapstuff move.b rgltemp1(rgl_gcb),curson(a0) restore value of CURSON init_cmapstuff equ * SFB 6/11/85 * DO NOT DO CMAP INIT TRAVERSAL, AS IT RESETS COLORS * 0,1,254,255. WILL SET TCOL (NEREID) IN GLE_RGL SFB 6/25/85 * movep cmapidoff(a0),d0 get ptr to color map id reg * tst d0 if ptr = 0 then no color map * beq.s std_rom_done * move.b 0(a0,d0),d1 get cmap id into d1 * and #3,d1  look at least sig bits * lsl #2,d1 * move.b cmapinitoff(a0,d1.w),d2 form cmap init block addr * lsl #8,d2 * move.b cmapinitoff+2(a0,d1.w),d2 * movea.l a0,a1 * adda d2,a1  a1 points to cmap init block * jsr ginitblock std_rom_done equ * bra rts * * procedure graphics_on_off ( gcb : graphics_control_block_ptr ) * gle_aras_out_rgraphics_on_off equ * * movea.l 4(sp),gle_gcb  a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb move.w devicetype(rgl_gcb),d0 cmp.w #2,d0 3  moonunit is only device that beq.s on_off_tst supports this call bra rts on_off_tst add.w d0,d0 tst.l info1(gle_gcb) { info1 = 0 is goff } beq.s goff_98627 gon_98627 movea.l deviceaddress(rgl_gcb),a0 move.b #$80,1(a0) bra rts goff_98627 movea.l deviceaddress(rgl_gcb),a0 move.b #0,1(a0) bra rts page ************************************************************************ * moon_map2 dc.b 0 0 dc.b  7 1 white dc.b 4 2 red dc.b 6 3 yellow dc.b 2 4 green dc.b 3 5 cyan dc.b 1 6 blue dc.b 5 7 magenta **************************************************************************** * * procedure clear ( gcb : graphics_control_block_ptr ) * * INFO1 = Plane clear information * INFO2 = Plane select information * gle_aras_out_rclear equ * movea.l 4(sp),gle_gcb  a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb move.l info1(gle_gcb),d7 clear ? plane word bne.s gclr0 move.l #-1,d7 gclr0 movea.l plane1_addr(rgl_gcb),a0 ptr to address movea.l (a0),a0 adda.l plane1_offset(rgl_gcb),a0 upper right display address gclr1 cmpi.b #3,devicetype+1(rgl_gcb) beq  gclr36c movea.l a0,a1 movea.l a0,a2 adda.l plane2_offset(rgl_gcb),a1 adda.l plane3_offset(rgl_gcb),a2 moveq #0,d3 move.b info2+3(gle_gcb),d3 cmpi.w #2,devicetype(rgl_gcb) ck for moonunit bne.s g0 move.b moon_map2(d3),d3 remap for moonunit g0 moveq #0,d0 btst #0,d3 beq.s g1 moveq #-1,d0 g1 moveq #0,d1 btst #1,d3 beq.s g2 moveq #-1,d1 g2 moveq #0,d2 btst #2,d3 beq.s g3 moveq #-1,d2 g3 move n_glines(rgl_gcb),d6 cmpi.b #2,devicetype+1(rgl_gcb) if it's color, we have to clear bne.s gclr1a everything. move #512,d6 gclr1a mulu bytesperline(rgl_gcb),d6 gclr4 lsr.l #2,d6 d6 = # of long words to clear ror.l #3,d6 do them in groups of 8 longwords cmpi.b #2,devicetype+1(rgl_gcb) beq.s gclrloop and.b #$1,d7  mask off green and red for b&w gclrloop btst #0,d7 alter plane1 ? beq.s gclrloop1 move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ move.l d0,(a0)+ gclrloop1 btst #1,d7 alter plane2 ? beq.s gclrloop2 move.l d1,(a1)+ move.l d1,(a1)+ move.l d1,(a1)+ move.l d1,(a1)+ move.l d1,(a1)+ move.l  d1,(a1)+ move.l d1,(a1)+ move.l d1,(a1)+ gclrloop2 btst #2,d7 alter plane3 ? beq.s gclrloop3 move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ move.l d2,(a2)+ gclrloop3 subq #1,d6 bne gclrloop Changed from bgt - CFB 2DEC91 rol.l #3,d6 beq rts * loop to finish any left-over words gclrlp btst #0,d7 alter plane1 ? blt.s gclrlp1 move.l d0,(a0)+ gclrlp1 btst #1,d7 alter plane2 ? blt.s gclrlp2 move.l d1,(a1)+ gclrlp2 btst #2,d7 alter plane3 ? blt.s gclrlp3 move.l d2,(a2)+ gclrlp3 subq #1,d6 bgt gclrlp bra rts gclr36c move n_glines(rgl_gcb),d0 mulu bytesperline(rgl_gcb),d0 adda.l d0,a0 and.l #15,d7 cmpi.b #15,d7 beq.s gclr364 c_all move.l d7,d2 asl.l #8,d2 add.l d7,d2 asl.l #8,d2 add.l d7,d2 asl.l #8,d2 add.l d7,d2 not.l d2 lsr.l #4,d0 div by 16 subq.l #1,d0 g36c_ploop equ * and.l d2,-(a0) and.l d2,-(a0) and.l d2,-(a0) and.l d2,-(a0) dbra d0,g36c_ploop bra rts gclr36c_all equ * divu #192,d0 clear 48 long words at a time subq #1,d0 ext.l d0 moveq #0,d1 move.l d1,d2 move.l d1,d3 move.l d1,d4 move.l d1,d5 move.l d1,d6 move.l d1,d7 movea.l d1,a1 movea.l a1,a2 movea.l a1,a3 movea.l a1,a5 movea.l a1,a6 gclrloop36 movem.l d1-d7/a1-a3/a5/a6,-(a0)  movem.l d1-d7/a1-a3/a5/a6,-(a0) movem.l d1-d7/a1-a3/a5/a6,-(a0) movem.l d1-d7/a1-a3/a5/a6,-(a0) dbra d0,gclrloop36 bra rts ***************************************************************************** * * procedure move (gcb: graphics_control_block_ptr); * gle_aras_out_rmove movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address move.l end_x(gle_gcb),d4 move.l end_y(gle_gcb),d5 move.l d4,current_pos_x(gle_gcb) move.l d5,current_pos_y(gle_gcb) rts page ***************************************************************************** * clip_draw equ * exg d5,d6 jsr gle_asclip_clipping exg d5,d6 cmpi.b #1,d0 ble.s vector1 bra rts ***************************************************************************** * clip_xmin equ a0 clip_xmax equ a1 clip_ymin equ a2 clip_ymax equ a3 * * procedure draw (gcb: graphics_control_block_ptr); * gle_aras_out_rdraw movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb move.l current_pos_x(gle_gcb),d4 move.l current_pos_y(gle_gcb),d6 move.l end_x(gle_gcb),d5 move.l end_y(gle_gcb),d7 move.l d5,current_pos_x(gle_gcb) move.l d7,current_pos_y(gle_gcb) movem.l clip_limits_xmin(gle_gcb),a0-a3 cmp.l clip_xmin,d4  x0 < clip_xmin blt.s clip_draw cmp.l clip_xmax,d4 x0 > clip_xmax bgt.s clip_draw cmp.l clip_ymin,d6 y0 < clip_ymin blt.s clip_draw cmp.l clip_ymax,d6  y0 > clip_ymax bgt.s clip_draw cmp.l clip_xmin,d5 x1 < clip_xmin blt.s clip_draw cmp.l clip_xmax,d5 x1 > clip_xmax bgt.s clip_draw cmp.l clip_ymin,d7  y1 < clip_ymin blt.s clip_draw cmp.l clip_ymax,d7 y1 > clip_ymax bgt.s clip_draw vector1 movea.l plane1_addr(rgl_gcb),a0 movea.l (a0),a0 get address adda.l plane1_offset(rgl_gcb),a0 upper right display address movem.l plane2_offset(rgl_gcb),a2/a3 move gspacing(rgl_gcb),d0 subq #1,d0 adda.w d0,a0 adjust for 16/26 odd addressing move current_linestyle_pattern(gle_gcb),oldpattern(rgl_gcb) movea.l status(a5),a1 prepare to check line/block mover ready cmpi.b #gator_display,devicetype+1(rgl_gcb) bne.s checkgbox loopstg btst #7,1(a1) wait for gator line mover beq.s loopstg bra.s setvec_rr checkgbox cmpi.b #gatorbox_display,devicetype+1(rgl_gcb) bne.s checkbobcat waitgboxbm btst #4,(a1) wait for gatorbox tile mover bne waitgboxbm bra.s setvec_rr checkbobcat cmpi.b #bobcat_display,devicetype+1(rgl_gcb) blt.s vec1 bugfix 3.1C SFB 5/23/85 checkwoodcut cmpi.b #catseye_hrx_display,devicetype+1(rgl_gcb) CFB 10JUN91 bgt.s vec1 CFB 10JUN91 * don't4  need to wait for window mover to change bobcat pixel repl rule !!! move.w #$300,d3 special case for bobcat bra.s do_set_rr repl rule 3 in msb of word setvec_rr moveq #3,d3  generic repl rule 3 do_set_rr movea.l rule(a5),a1 move.w d3,(a1) and set (pixel) repl rule vec1 cmp d6,d7 if y1=y2 bne.s vec2 and if solid line cmpi #-1,current_linestyle_pattern(gle_gcb) bne.s vec2 move pen_draw_mode(rgl_gcb),d0 and if draw mode is dominant bne.s vec2 bra horiz_vec then draw horizontal vector vec2 moveq #0,d0  clear 'y1:y2 swapped' flag move d7,d2 sub d6,d2 d2 = y2 - y1 bge.s d2plus y2 was > y1 neg d2 make y2 > y1 exg d4,d5 exg  d6,d7 d6 = smaller y moveq #1,d0 set [y1:y2 swapped] flag d2plus sub d4,d5 d5 = x2-x1 move current_linestyle_pattern(gle_gcb),d3 cmp #-1,d3 beq.s vec6  solid line : all is well move d5,d1 d1 = x2-x1 bge.s vec3 neg d1 d1 = abs(x2-x1) vec3 cmp d1,d2 d1 = # of pixels in vector blt.s vec4 move d2,d1 vec4 move current_linestyle_pattern(gle_gcb),d3 * * Non-trivial fixup of the repeat pattern based on repeatcount * and repeatrate: The final current_linestyle_pattern and repeatcount are * calculated before the vector loop is entered. This prevents a messy * self-modification section in the vector generator itself, and limits all self * modifying code to subroutine 'buildpen'. If the line must be drawn backwards * (i.e. the passed y2 was less than y1), the final current_linestyle_pattern and * repeatcount calculated here are used as the starting point. * * Of course, all of this is skipped for solid lines * move repeatcount(rgl_gcb),t4(rgl_gcb) cmp repeatcount(rgl_gcb),d1 blt.s smallvec sub repeatcount(rgl_gcb),d1 ext.l d1 divu repeatrate(rgl_gcb),d1 addq #1,d1 Q=Q+1 rol d1,d3 rotate the current_linestyle_pattern swap d1 d1 = R  neg d1 add repeatrate(rgl_gcb),d1 d1=repeatrate-R move d1,repeatcount(rgl_gcb) bra.s vec5 smallvec sub d1,repeatcount(rgl_gcb) vec5 move d3,oldpattern(rgl_gcb) update oldpattern for next pass tst d0 beq.s vec6 lsl.b #1,d3 swap the 16 bits in d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 roxr #1,d3 roxl.b #2,d3 ror #1,d3 move d3,current_linestyle_pattern(gle_gcb) start with last pattern move  repeatrate(rgl_gcb),d0 sub repeatcount(rgl_gcb),d0 addq #1,d0 move d0,t4(rgl_gcb) vec6 movea bytesperline(rgl_gcb),a1 not d6 d6 = -y-1 add n_glines(rgl_gcb),d6 d6 = (n_glines-1)-y mulu bytesperline(rgl_gcb),d6 adda.l d6,a0 a0 = addr of line with 1st pixel cmpi.b #3,devicetype+1(rgl_gcb) if 36c/gatorgatorbox/bobcat blt.s not36c then do 36c stuff * compute address of first pixel for byte/pixel frame buffer adda d4,a0 add x1 to start address move cpen(rgl_gcb),d0 d0 = pen (or not pen if erase) cmpi.b #7,devicetype+1(rgl_gcb) bobcatlores ? bne 5  vecready mulu #257,d0 yes, dup pen value in both bytes adda d4,a0 and double x1 for "real" pixels bra.s vecready * compute address and bit position of first pixel for bit/pixel frame buffer not36c move gspacing(rgl_gcb),d0 move d0,d6 subq #1,d0 move d4,d1 d1 = starting x lsr #3,d1 lsl d0,d1 adda d1,a0 a0 points to first byte to alter and #7,d4 d4 = bit number of first pixel moveq #$80,d0 d0 = bit pattern to rotate ror.b d4,d0 align it for starting position move d0,d1 not d1  use d1 for the 'and' mask vecready move #$8000,d3 sum = 0.50000 move current_linestyle_pattern(gle_gcb),d4 movea repeatrate(rgl_gcb),a5 move t4(rgl_gcb),d7 jsr softvec(rgl_gcb) move oldpattern(rgl_gcb),current_linestyle_pattern(gle_gcb) bra rts horiz_vec cmp d4,d5 bge.s hv10 exg d4,d5 hv10 not d6 d6 = -y-1 add n_glines(rgl_gcb),d6 d6 = (n_glines-1)-y mulu bytesperline(rgl_gcb),d6 adda.l d6,a0 a0 = addr of line with 1st pixel move d4,d2 d2=d4=x1 move d5,d3 d3=d5=x2 cmpi.b #3,devicetype+1(rgl_gcb) bge hv50 36C/gator/gatorbox/bobcat * bgt hvgat lsr #3,d2 d2=x1 div 8 lsr #3,d3 d3=x2 div 8 and #7,d4 d4=x1 mod 8 and #7,d5  d5=x2 mod 8 sub d2,d3 d3=# of bytes to do - 1 addq #1,d5 adda d2,a0 a0 points to 1st byte to modify movea gspacing(rgl_gcb),a1 tst devicetype(rgl_gcb) 9816 or 9826 ? bne.s hv20 adda d2,a0 on 9826 & 9816 add it twice hv20 moveq #-1,d2 btst #1,devicetype+1(rgl_gcb) is this color ? beq.s hv30 no adda.l a0,a2  a2 points to green plane adda.l a0,a3 a3 points to red plane move d3,d6 save the byte count (d1) moveq #-1,d2 btst #2,pen_num+1(rgl_gcb) bne.s hv22 moveq #0,d2 hv22 bsr.s hv40 draw the blue plane move d6,d3 restore the byte count movea.l a2,a0 a0 points to green plane moveq #-1,d2 btst #1,pen_num+1(rgl_gcb) bne.s hv24 moveq #0,d2 hv24 bsr.s hv40 draw the green plane move d6,d3 restore byte count movea.l a3,a0 a0 points to red plane moveq #-1,d2 btst #0,pen_num+1(rgl_gcb) bne.s hv30 moveq #0,d2 hv30 bsr.s hv40 bra rts hv40 tst d3 how many bytes are effected ? bne.s hv41 more than one move.b (a0),d2  g->mask.b rol.b d5,d2 rol d4,d2 ror d5,d2 ror.w x2b-x1b+1,mask ror.b d4,d2 move.b d2,(a0) mask->g rts hv41 move.b (a0),d0 rol d4,d0 move.b d2,d0 rol.b d4,d0 ror d4,d0 move.b d0,(a0) adda.l a1,a0 subq #2,d3 blt.s hv43 hv42 move.b d2,(a0) adda.l a1,a0 dbra d3,hv42 hv43 rol d5,d2 move.b (a0),d2 rol.b d5,d2 ror d5,d2 move.b d2,(a0) rts hv50 cmpi.b #7,devicetype+1(rgl_gcb) bobcatlores ? bne.s hv50_a NO asl #1,d2 double x1 for "real" pixel asl #1,d3 5  double x2 for "real" pixel addq #1,d3 and fill to end (SFB 7/8/85} asl #1,d4 double x1 for "real" pixel asl #1,d5 double x2 for "real" pixel addq #1,d5 and fill to end (SFB 7/8/85} hv50_a equ * and #3,d4 x1 mod 4 and #3,d5 x2 mod 4 lsl #2,d4 (x1 mod 4)*4 mask index lsl #2,d5  (x2 mod 4)*4 mask index and #$fffc,d2 x1 div 4 adda d2,a0 (a0) first long w that changes lsr #2,d2 # of nibbles to x1 lsr #2,d3  # of nibbles to x2 sub d2,d3 # of nibbles to do -1 move cpen(rgl_gcb),d0 move d0,d1 lsl #8,d0 move.b d1,d0 move d0,d1 swap d0 move d1,d0 move.l d0,d1 move.l hvmask1(d4),d4 tst d3 bne.s hv52 hv51 and.l hvmask2(d5),d4 moveq #0,d3 hv52 and.l d4,d1 not.l d4 and.l d4,(a0) or.l d1,(a0)+ dbra d3,hv53 bra rts hv53 moveq #-1,d4 move.l d0,d1 tst d3 beq.s hv51 subq #1,d3 hv54 move.l d0,(a0)+ dbra d3,hv54 bra.s hv51 hvmask1 dc.l $ffffffff dc.l $00ffffff dc.l $0000ffff dc.l $000000ff hvmask2 dc.l $ff000000 dc.l $ffff0000 dc.l $ffffff00 dc.l $ffffffff page **************************************************************************** * * DEFINE_DRAWING_MODE ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); * * Modes are: * INFO1 = 0 - Dominant * = 1 - Erase * = 2 - Non-dominant * = 3 - Complement * gle_aras_out_rdefine_drawing_mode equ * * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = dev_dep_gcb move.l info1(gle_gcb),d0 d0 = new drawing mode move.w d0,current_drawing_mode(gle_gcb) bra set_pen **************************************************************************** * * SET_COLOR ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); * * Color index is in INFO1 * * Note: Colors are assigned as follows on non-color map units: * INFO1 = 0 - Undefined * 1 - White * 2 - Red * 3 - Yellow * 4 - Green * 5 - Cyan * 6 - Blue * 7 - Magenta * * On color map units, the pen number is the index to the CMAP * gle_aras_out_rset_color equ * * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb move.w info1+2(gle_gcb),current_color_index(gle_gcb) bra set_pen **************************************************************************** * * LINESTYLE ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); * * INFO1 = Linestyle index (saved only by raster devices) * INFO2 = Pattern length, % of min and max display values * INFO3 = Linestyle mode (saved only by these devices) * INFO4 = Raster pattern (16 bit value) * gle_aras_out_rlinestyle equ * * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = dev_dep_gcb move.w info1+2(gle_gcb),current_linestyle(gle_gcb) move.w info2+2(gle_gcb),d0 move.w d0,current_pattern_length(gle_gcb) muls  hard_xmax(rgl_gcb),d0 divs #1600,d0 bgt.s ls_1 moveq #1,d0 ls_1 move.w d0,repeatrate(rgl_gcb) move.w info3+2(gle_gcb),current_linestyle_mode(gle_gcb) move.w info4+2(gle_gcb),current_linestyle_pattern(gle_gcb) 6  bsr build_pen bra set_pen ************************************************************************ * moon_map dc.b 0 0 dc.b 7 1 white dc.b 1 2 red dc.b 3 3 yellow dc.b 2 4 green dc.b 6 5 cyan dc.b 4 6 blue dc.b 5 7 magenta *********************************************************************** * * build_pen * * This procedure takes devicetype, and linestyle and generates * the 68000 instructions for the vector generator. The code * space for the vector generator is in the GCB, so that nothing * in this segment will modify itself. * build_pen equ *  | build first template c_set2 move.w #0,pen_draw_mode(rgl_gcb) move.w #1,pen_num(rgl_gcb) move devicetype(rgl_gcb),d0 cmpi.b #gator_display,devicetype+1(rgl_gcb) * bne.s skip_notgat blt.s skip_notgat move #3,d0 gator/gatorbox/bobcat -- reset d0 like 36c skip_notgat lsl #2,d0 cmpi #-1,current_linestyle_pattern(gle_gcb) ck linestyle bne.s fixpatternx1 bra.s fixpattern1 | else create solid vec gen. ztable dc.w template1-ztable dc.w template2-ztable dc.w template1-ztable dc.w template2-ztable dc.w template3-ztable dc.w template4-ztable dc.w template5-ztable dc.w template6-ztable * d0 = 0 9826 (bit/pixel odd bytes) * 4 9836A (bit/pixel all bytes) * 8 98627A (multi-plane) *  12 9836C (byte-per-pixel) fixpatternx1 addq #2,d0 fixpattern1 movea ztable(d0),a0 a0 = offset ptable to template lea ztable(a0),a0 a0 = address of template lea softvec(rgl_gcb),a1 a1 = address of ram area moveq #12,d1 d1 = counter * copy the template vector generator into ram. loadtmplt move.l (a0)+,(a1)+ move.l (a0)+,(a1)+ move.l (a0)+,(a1)+ move.l (a0)+,(a1)+ move.l (a0)+,(a1)+ subq #1,d1 bgt loadtmplt jsr asm_flush_icache {3/25/85 SFB} rts ****************************************************************************** * * set_pen * * This procedure takes devicetype, current_linestyle_pattern, pen_num * and drawing_mode and modifies the current vector generator code. * The code space for the vector generator is in the GCB, so that * nothing in this segment will modify itself. * If the current pen color matches the previous pen color, *  this routine will just rts. If you want to make sure * this routine builds something in the softvec area, put a 0 * in oldpattern. * set_pen equ * move.w current_drawing_mode(gle_gcb),d0 move.w current_color_index(gle_gcb),d1  cmpi.w #2,devicetype(rgl_gcb) ck for moonunit bne.s c_set1s move.b moon_map(d1),d1 remap for moonunit c_set1s tst.b d1 ck for color 0 bne.s c_set2s moveq #1,d0 force drawing mode to erase move.l gamut(gle_gcb),d1 set pen number to max c_set2s move.w d0,pen_draw_mode(rgl_gcb) move.w d1,pen_num(rgl_gcb) move d0,d3 add d3,d3 move devicetype(rgl_gcb),d0 *cmpi.b #bobcat_lores_display,devicetype+1(rgl_gcb) *bne.s ckbitmap2 *move #4,d0 *bra.s skip_nogat *ckbitmap2 equ * cmpi.b #gator_display,devicetype+1(rgl_gcb) blt.s skip_nogat move #3,d0 gator/gatorbox/bobcat -- reset d0 like 36c skip_nogat lsl #2,d0 cmpi #-1,current_linestyle_pattern(gle_gcb) beq.s fixpatterns addq #2,d0 fixpatterns equ * fixcolor add d0,d0 jmp fixc(d0) fixc jmp fixc1 jmp fixc2 jmp fixc1 jm6 p fixc2 jmp fixc3 jmp fixc4 jmp fixc5 jmp fixc6 ****************************************************************************** *********************************************** * * patch up bw solid vector generator * *********************************************** fixc1 move fixc1table(d3),d1 move d1,softvec+26(rgl_gcb) move d1,softvec+56(rgl_gcb) move d1,softvec+92(rgl_gcb) move d1,softvec+122(rgl_gcb) moveq #$64,d1  bcc instruction move #$4e71,softvec(rgl_gcb) nop instruction subq #2,d3 bne.s fixd1 moveq #$65,d1 move #$4600,softvec(rgl_gcb) not d0 instruction fixd1 move.b d1,softvec+34(rgl_gcb) move.b d1,softvec+70(rgl_gcb) move.b d1,softvec+100(rgl_gcb) move.b d1,softvec+136(rgl_gcb) jsr asm_flush_icache {3/25/85 SFB} bra rts fixc1table or.b d0,(a0) dominant and.b  d0,(a0) erase or.b d0,(a0) non-dominant (same) eor.b d0,(a0) compliment *********************************************** * * fix up bw dashed generator * *********************************************** fixc2 move fixc1table(d3),d1 move d1,softvec+30(rgl_gcb) move d1,softvec+72(rgl_gcb) move d1,softvec+120(rgl_gcb) move d1,softvec+162(rgl_gcb) moveq #$64,d1 bcc instruction move #$4e71,softvec(rgl_gcb) nop instruction subq #2,d3 bne.s fixd2 moveq #$65,d1 bcs instruction move #$4600,softvec(rgl_gcb) not d0 instruction fixd2 move.b d1,softvec+46(rgl_gcb) move.b d1,softvec+94(rgl_gcb) move.b d1,softvec+136(rgl_gcb) move.b d1,softvec+184(rgl_gcb) jsr asm_flush_icache {3/25/85 SFB} bra rts *********************************************** * * fix up moon solid vector generator * *********************************************** fixc3 move cblu(d3),d0 btst #2,pen_num+1(rgl_gcb) bne.s fx3_10 move cblu+8,d0 tst d3 bne.s fx3_10 move cblu+2,d0 fx3_10 add d3,d3 move.l cgrn(d3),d1 move.l cred(d3),d2 btst #1,pen_num+1(rgl_gcb) bne.s fx3_20 move.l cgrn+16,d1 tst d3 bne.s fx3_20 move.l cgrn+4,d1 fx3_20 btst #0,pen_num+1(rgl_gcb) bne.s fx3_30 move.l cred+16,d2 tst d3 bne.s fx3_30 move.l cred+4,d2 fx3_30 lea softvec+24(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ lea softvec+64(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ lea softvec+110(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ lea softvec+150(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ jsr asm_flush_icache {3/25/85 SFB} bra rts cblu or.b d0,(a0) dominant and.b d1,(a0) erase or.b d0,(a0) non-dominant eor.b d0,(a0)  compliment nop cgrn or.b d0,0(a0,a2.l) and.b d1,0(a0,a2.l) or.b d0,0(a0,a2.l) eor.b d0,0(a0,a2.l) nop nop cred or.b d0,0(a0,a3.l) and.b d1,0(a0,a3.l) or.b d0,0(a0,a3.l) eor.b d0,0(a0,a3.l) nop nop *********************************************** * * fix up moon dashed generator * *********************************************** fixc4 move cblu(d3),d0 btst #2,pen_num+1(rgl_gcb) bne.s fx4_10 move cblu+8,d0 tst d3 bne.s fx4_10 move cblu+2,d0 fx4_10 add d3,d3 move.l cgrn(d3),d1 move.l cred(d3),d2 btst #1,pen_num+1(rgl_gcb) bne.s fx4_20 move.l cgrn+16,d1 tst d3 7  bne.s fx4_20 move.l cgrn+4,d1 fx4_20 btst #0,pen_num+1(rgl_gcb) bne.s fx4_30 move.l cred+16,d2 tst d3 bne.s fx4_30 move.l cred+4,d2 fx4_30 lea softvec+28(rgl_gcb),a0 move d0,(a0)+  move.l d1,(a0)+ move.l d2,(a0)+ lea softvec+80(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ lea softvec+138(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ lea  softvec+190(rgl_gcb),a0 move d0,(a0)+ move.l d1,(a0)+ move.l d2,(a0)+ jsr asm_flush_icache {3/25/85 SFB} bra rts *********************************************** * * fix up 9836c solid lines (also gatorbox and bobcats) * *********************************************** fixc5 move pen_num(rgl_gcb),d0 cmpi.b #bobcat_lores_display,devicetype+1(rgl_gcb) bne fixc5_a addq #8,d3 move pointer down to bobcat lores opcodes move.w addq2,softvec+24(rgl_gcb) adjust address inc/dec opcodes move.w subq2,softvec+66(rgl_gcb) move.w addq2,softvec+126(rgl_gcb) fixc5_a equ * move color36c(d3),d2 move d2,softvec+52(rgl_gcb) move d2,softvec+112(rgl_gcb) move color36c2(d3),d2 move d2,softvec+26(rgl_gcb) move color36c3(d3),d2 move d2,softvec+86(rgl_gcb) cmpi #1,pen_draw_mode(rgl_gcb) bne fx5_10 not.b d0 fx5_10 move d0,cpen(rgl_gcb)  jsr asm_flush_icache {3/25/85 SFB} bra rts color36c move.b d0,(a0) and.b d0,(a0) or.b d0,(a0) eor.b d0,(a0) move.w d0,(a0) bobcat lores opcode and.w d0,(a0) bobcat lores opcode  or.w d0,(a0) bobcat lores opcode eor.w d0,(a0) bobcat lores opcode color36c2 move.b d0,-(a0) and.b d0,-(a0) or.b d0,-(a0) eor.b d0,-(a0) move.w d0,-(a0) bobcat lores opcode and.w d0,-(a0) bobcat lores opcode or.w d0,-(a0) bobcat lores opcode eor.w d0,-(a0) bobcat lores opcode color36c3 move.b d0,(a0)+ and.b d0,(a0)+ or.b d0,(a0)+ eor.b d0,(a0)+ move.w d0,(a0)+ bobcat lores opcode  and.w d0,(a0)+ bobcat lores opcode or.w d0,(a0)+ bobcat lores opcode eor.w d0,(a0)+ bobcat lores opcode addq2 addq #2,a0 opcode is addq #2,a0 subq2 subq #2,a0 opcode is subq #2,a0 *********************************************** * * fix up 9836c dashed lines (also gatorbox and bobcats) * *********************************************** fixc6 move pen_num(rgl_gcb),d0 cmpi.b #bobcat_lores_display,devicetype+1(rgl_gcb) bne  fixc6_a addq #8,d3 move pointer down to bobcat lores opcodes move.w subq2,softvec+42(rgl_gcb) adjust address inc/dec opcodes move.w subq2,softvec+86(rgl_gcb) move.w addq2,softvec+124(rgl_gcb) 3.1C BUGFIX 5/22/85--SFB  move.w addq2,softvec+168(rgl_gcb) fixc6_a equ * move color36c(d3),d2 move d2,softvec+28(rgl_gcb) move d2,softvec+66(rgl_gcb) move d2,softvec+110(rgl_gcb) move d2,softvec+148(rgl_gcb) cmpi #1,pen_draw_mode(rgl_gcb) if erase then bne fx6_10 not.b d0 invert pen number fx6_10 move d0,cpen(rgl_gcb) jsr asm_flush_icache {3/25/85 SFB} bra rts page ************************************************************************ * * these are the 6 templates for vector generators. the six cases are: * * template1 - monochrome / solid line * template2 - monochrome / dashed line * template3 - moonunit / solid line * template4 - moonunit / dashed line * template5 - 9836C / solid line * template6 - 9836C / dashed line * ************************************************************************ ***************************************************************7 ********* * * * TEMPLATE 1 - bw / solid line * * * ************************************************************************ ************************************************************************ template1 nop 0 tst d5 tst (x2-x1) 2 bgt.s incx1 4 neg d5 d5 = abs(x2-x1) 6 cmp d5,d2 x major or y major ? 8 bgt.s case13 y major/decrement x 10 * * x major/dec x * * rule: always decrement x / maybe increment y * case14 tst d5 12 beq.s loop14 14 swap d2 d2 = [(y2-y1) : 0 ] 16 clr d2  18 divu d5,d2 d2 = (y2-y1)/(x2-x1) 20 bvc.s loop14 22 moveq #-1,d2 24 loop14 or.b d0,(a0) .................................26  subq #1,d5 28 blt.s endvec1 30 rol.b #1,d0 .................................32 bcc.s next14 .................................34 suba d6,a0  36 next14 add d2,d3 sum = sum + frac 38 bcc loop14 40 suba a1,a0 inc y 42 bra loop14  44 * * y major / dec x * * rule: always increment y / maybe decrement x * case13 swap d5 46 clr d5 48 divu d2,d5 d5=frac=(x2-x1)/(y2-y1) 50 bvc.s loop13 52 moveq #-1,d5 54 loop13 or.b d0,(a0) ...............................56 subq #1,d2 pixel_count = pixel_count - 1 58  blt.s endvec1 if pixel_count<0 ; goto endvec 60 suba a1,a0 increment y 62 add d5,d3 sum = sum + frac 64 bcc loop13 if sum < 1 then goto loop3 66 rol.b #1,d0 ...............................68 bcc loop13 ...............................70 suba d6,a0 72 bra loop13 74 endvec1 rts  76 incx1 cmp d5,d2 78 bgt.s case11 80 * * x major / inc x * * rule: always increment x / maybe increment y * case12 swap d2  82 clr d2 84 divu d5,d2 d2 = frac 86 bvc.s loop12 88 moveq #-1,d2 90 loop12 or.b d0,(a0) ................................92 subq #1,d5 94 blt.s endvec1 96 ror.b #1,d0 ................................98 bcc.s next12  ...............................100 adda d6,a0 102 next12 add d2,d3 sum = sum + frac 104 bcc loop12 106 suba a1,a0  108 bra loop12 110 * * y major / inc x * * rule: maybe inc x / always inc y * case11 swap d5 112 clr d5 8 114 divu d2,d5 116 bvc.s loop11 118 moveq #-1,d5 120 loop11 or.b d0,(a0) ................................122 subq #1,d2 124 blt.s endvec1 126 suba a1,a0 128 add d5,d3 130 bcc loop11  132 ror.b #1,d0 134 bcc loop11 ................................136 adda d6,a0 138 bra loop11 140  page ************************************************************************ ************************************************************************ * * * TEMPLATE 2 - bw / dashed line * * * ************************************************************************ ************************************************************************ template2 nop 0 tst d5 tst (x2-x1) 2 bgt.s incx2 4 neg d5 d5 = abs(x2-x1) 6 cmp  d5,d2 x major or y major ? 8 bgt.s case23 y major/decrement x 10 * * x major/dec x * * rule: always decrement x / maybe increment y * case24 tst d5 12 beq.s loop24 14 swap d2 d2 = [(y2-y1) : 0 ] 16 clr d2 18 divu d5,d2 d2 = (y2-y1)/(x2-x1) 20 bvc.s loop24  22 moveq #-1,d2 24 loop24 tst d4 if bit 7 of pattern is set 26 bpl.s skip24 then skip - the pen is up 28 or.b d0,(a0) else draw - the pen is down 30 skip24 subq #1,d5 pixel_count := pixel_count-1 32 blt.s endvec2 34 subq #1,d7 decrement repeatcount 36 bne.s ok24 38 move a5,d7 40 rol #1,d4 42 ok24 rol.b #1,d0 44 bcc.s next24 ...............................46 suba d6,a0  48 next24 add d2,d3 sum = sum + frac 50 bcc loop24 52 suba a1,a0 inc y 54 bra loop24  56 * * y major / dec x * * rule: always increment y / maybe decrement x * case23 swap d5 58 clr d5 60 divu d2,d5 d5 = frac = (x2-x1)/(y2-y1) 62 bvc.s loop23 64 moveq #-1,d5 66 loop23 tst d4 if bit 7 of pattern is set 68 bpl.s skip23 70 or.b d0,(a0) turn on pixel (x,y) 72 skip23 subq #1,d2 pixel_count = pixel_count - 1 74 blt.s endvec2 if pixel_count<0 ;goto endvec 76 subq #1,d7 decrement repeatcount 78 bne.s ok23  80 move a5,d7 82 rol #1,d4 84 ok23 suba a1,a0 increment y 86 add d5,d3 sum = sum + frac 8  88 bcc loop23 if sum < 1 then goto loop3 90 rol.b #1,d0 x = x - 1 92 bcc loop23 ...............................94 suba d6,a0 96 bra loop23 98 endvec2 rts 100 incx2 cmp d5,d2 102 bgt.s case21 104 * * x major / inc x * * rule: always increment x / maybe increment y * case22 swap d2 106 clr d2 108 divu d5,d2 d2 = frac 110 bvc.s loop22  112 moveq #-1,d2 114 loop22 tst d4 116 bpl.s skip22 118 or.b d0,(a0) ..............................120 skip22 subq #1,d5 122 blt.s endvec2 124 subq #1,d7 decrement repeatcount 126 bne.s ok22 128 move a5,d7 130 rol #1,d4 132 ok22 ror.b #1,d0 134 bcc.s next22 ..............................136 adda d6,a0 138 next22 add d2,d3 sum = sum + frac 140 bcc loop22 142 suba a1,a0 144 bra loop22  146 * * y major / inc x * * rule: maybe inc x / always inc y * case21 swap d5 148 clr d5 150 divu d2,d5  152 bvc.s loop21 154 moveq #-1,d5 156 loop21 tst d4 158 bpl.s skip21 160 or.b d0,(a0) ..............................162 skip21 subq #1,d2 164 blt.s endvec2 166 subq #1,d7 decrement repeatcount 168 bne.s ok21  170 move a5,d7 172 rol #1,d4 174 ok21 suba a1,a0 176 add d5,d3  178 bcc loop21 180 ror.b #1,d0 182 bcc loop21 ..............................184 adda d6,a0 186 bra loop21 188 page ************************************************************************ ************************************************************************ *  * * TEMPLATE 3 - moonunit / solid line * * * ************************************************************************ ************************************************************************ template3 tst d5 tst (x2-x1) 0 bgt.s incx3 2 neg d5 d5 = abs(x2-x1) 4 cmp d5,d2 x major or y major ? 6 bgt.s case33 y major/decrement x 8 * * x major/dec x * * rule: always decrement x / maybe increment y * case34 tst d5 10 beq.s loop9 34 12 swap d2 d2 = [(y2-y1) : 0 ] 14 clr d2 16 divu d5,d2 d2 = (y2-y1)/(x2-x1) 18 bvc.s loop34  20 moveq #-1,d2 22 loop34 or.b d0,(a0) ............................24 or.b d0,0(a0,a2.l) ............................26 or.b d0,0(a0,a3.l) ............................30  subq #1,d5 34 blt.s endvec3 36 rol.b #1,d1 38 rol.b #1,d0 40 bcc.s next34  42 suba d6,a0 44 next34 add d2,d3 sum = sum + frac 46 bcc loop34 48 suba a1,a0 inc y  50 bra loop34 52 * * y major / dec x * * rule: always increment y / maybe decrement x * case33 swap d5 54 clr d5  56 divu d2,d5 d5 = frac = (x2-x1)/(y2-y1) 58 bvc.s loop33 60 moveq #-1,d5 62 loop33 or.b d0,(a0) turn on pixel (x,y)............64  or.b d0,0(a0,a2.l) ............................66 or.b d0,0(a0,a3.l) ............................70 subq #1,d2 pixel_count = pixel_count - 1 74 blt.s endvec3 if pixel_count<0 ; goto endvec 76 suba a1,a0 increment y 78 add d5,d3 sum = sum + frac 80 bcc loop33 if sum < 1 then goto loop3 82 rol.b #1,d1 84 rol.b #1,d0 x = x - 1  86 bcc loop33 88 suba d6,a0 90 bra loop33 92 endvec3 rts 94 incx3  cmp d5,d2 96 bgt.s case31 98 * x major / inc x * rule: always increment x / maybe increment y case32 swap d2 100 clr d2 102 divu d5,d2 d2 = frac 104 bvc.s loop32 106 moveq #-1,d2 108 loop32 or.b d0,(a0)  ...........................110 or.b d0,0(a0,a2.l) ...........................112 or.b d0,0(a0,a3.l) ...........................116 subq #1,d5 120 blt.s endvec3  122 ror.b #1,d1 124 ror.b #1,d0 126 bcc.s next32 128 adda d6,a0 130 next32 add d2,d3 sum = sum + frac 132 bcc loop32 134 suba a1,a0 136 bra loop32 138 * * y major / inc x * * rule: maybe inc x / always inc y * case31 swap d5 140 clr d5 142 divu d2,d5 144 bvc.s loop31  146 moveq #-1,d5 148 loop31 or.b d0,(a0) ...........................150 or.b d0,0(a0,a2.l) ...........................152 or.b d0,0(a0,a3.l) ...........................156 s9 ubq #1,d2 160 blt.s endvec3 162 suba a1,a0 164 add d5,d3 166 bcc loop31  168 ror.b #1,d1 170 ror.b #1,d0 172 bcc loop31 174 adda d6,a0 176 bra loop31 178 page ************************************************************************ ************************************************************************ *  * * TEMPLATE 4 - moonunit / dashed lines * * * ************************************************************************ ************************************************************************ template4 tst d5 tst (x2-x1) 0 bgt.s incx4 2 neg d5 d5 = abs(x2-x1) 4  cmp d5,d2 x major or y major ? 6 bgt.s case43 y major/decrement x 8 * * x major/dec x * * rule: always decrement x / maybe increment y * case44 tst d5 10 beq.s loop44 12 swap d2 d2 = [(y2-y1) : 0 ] 14 clr d2 16 divu d5,d2 d2 = (y2-y1)/(x2-x1) 18 bvc.s loop44  20 moveq #-1,d2 22 loop44 tst d4 24 bpl.s skip44 26 or.b d0,(a0) ............................28 or.b d0,0(a0,a2.l) ............................30 or.b d0,0(a0,a3.l) ............................34 skip44 subq #1,d5 38 blt.s endvec4 40 subq #1,d7 42 bne.s ok44 44 move a5,d7 46 rol #1,d4 48 ok44 rol.b #1,d1  50 rol.b #1,d0 52 bcc.s next44 54 suba d6,a0 56 next44 add d2,d3 sum = sum + frac  58 bcc loop44 60 suba a1,a0 inc y 62 bra loop44 64 * * y major / dec x * * rule: always increment y / maybe decrement x * case43 swap d5 66 clr d5 68 divu d2,d5 d5 = frac = (x2-x1)/(y2-y1) 70 bvc.s loop43 72 moveq #-1,d5 74 loop43 tst d4 76 bpl.s skip43 78 or.b d0,(a0) turn on pixel (x,y) ...........80 or.b d0,0(a0,a2.l) ............................82 or.b d0,0(a0,a3.l) ............................86 skip43 subq #1,d2 pixel_count = pixel_count - 1 90 blt.s endvec4 if pixel_count<0 ;goto endvec 92 subq #1,d7  94 bne.s ok43 96 move a5,d7 98 rol #1,d4 100 ok43 suba a1,a0 increment y 102 :  add d5,d3 sum = sum + frac 104 bcc loop43 if sum < 1 then goto loop3 106 rol.b #1,d1 108 rol.b #1,d0 x = x - 1 110 bcc loop43  112 suba d6,a0 114 bra loop43 116 endvec4 rts 118 incx4 cmp d5,d2  120 bgt.s case41 122 * * x major / inc x * * rule: always increment x / maybe increment y * case42 swap d2 124 clr d2  126 divu d5,d2 d2 = frac 128 bvc.s loop42 130 moveq #-1,d2 132 loop42 tst d4 134 bpl.s skip42 136 or.b d0,(a0) .............................138 or.b d0,0(a0,a2.l) 140 or.b d0,0(a0,a3.l) 144 skip42 subq #1,d5 148 blt.s endvec4 150 subq #1,d7 152 bne.s ok42 154 move a5,d7  156 rol #1,d4 158 ok42 ror.b #1,d1 160 ror.b #1,d0 162 bcc.s next42 164 adda d6,a0 166 next42 add d2,d3 sum = sum + frac 168 bcc loop42 170 suba a1,a0 172 bra loop42 174 * * y major / inc x * * rule: maybe inc x / always inc y * case41 swap d5 176 clr d5 178 divu d2,d5  180 bvc.s loop41 182 moveq #-1,d5 184 loop41 tst d4 186 bpl.s skip41  188 or.b d0,(a0) ...........................190 or.b d0,0(a0,a2.l) ...........................192 or.b d0,0(a0,a3.l) ...........................196 skip41 subq #1,d2 200 blt.s endvec4 202 subq #1,d7 204 bne.s ok41 206 move a5,d7 208 rol #1,d4  210 ok41 suba a1,a0 212 add d5,d3 214 bcc loop41 216 ror.b #1,d1  218 ror.b #1,d0 220 bcc loop41 222 adda d6,a0 224 bra loop41 226 page ************************************************************************ ************************************************************************ * * * TEMPLATE 5 - 9836C / solid line  * * * ************************************************************************ ************************************************************************ te: mplate5 tst d5 tst (x2-x1) 0 bgt.s incx5 2 neg d5 d5 = abs(x2-x1) 4 cmp d5,d2 x major or y major ? 6 bgt.s case53 y major/decrement x 8 * * x major/dec x * * rule: always decrement x / maybe increment y * case54 tst d5 10 beq.s before54 12 swap d2  d2 = [(y2-y1) : 0 ] 14 clr d2 16 divu d5,d2 d2 = (y2-y1)/(x2-x1) 18 bvc.s before54 20 moveq #-1,d2  22 before54 addq #1,a0 24 loop54 move.b d0,-(a0) .................................26 dbra d5,next54 28 bra.s endvec5 32 next54 add d2,d3 sum = sum + frac 34 bcc loop54 36 suba a1,a0 inc y 38 bra loop54 40 * * y major / dec x * * rule: always increment y / maybe decrement x * case53 swap d5 42 clr d5 44 divu d2,d5 d5=frac=(x2-x1)/(y2-y1) 46 bvc.s loop53 48 moveq #-1,d5 50 loop53 move.b d0,(a0) ...............................52 dbra d2,next53 pixel_count = pixel_count - 1 54 bra.s endvec5 if pixel_count<0 ; goto endvec 58 next53 suba a1,a0 increment y 60 add d5,d3 sum = sum + frac 62 bcc loop53 if sum < 1 then goto loop3 64 subq #1,a0  66 bra loop53 68 endvec5 rts 70 incx5 cmp d5,d2 72 bgt.s case51 74 * * x major / inc x * * rule: always increment x / maybe increment y * case52 swap d2 76 clr d2 78 divu d5,d2 d2 = frac 80 bvc.s loop52 82 moveq #-1,d2 84 loop52 move.b d0,(a0)+ ................................86 dbra d5,next52 88 bra.s endvec5  92 next52 add d2,d3 sum = sum + frac 94 bcc loop52 96 suba a1,a0 98 bra loop52  100 * * y major / inc x * * rule: maybe inc x / always inc y * case51 swap d5 102 clr d5 104 divu d2,d5 106 bvc.s loop51 108 moveq #-1,d5 110 loop51 move.b d0,(a0) ................................112 dbra d2,next51 114 bra.s endvec5 118 next51 suba a1,a0 120 add d5,d3 122 bcc loop51 124 addq #1,a0  126 bra loop51 128 page ************************************************************************ ************************************************************************ * ;  * * TEMPLATE 6 - 9836C / dashed line * * * ************************************************************************ ************************************************************************ template6 tst d5 tst (x2-x1) 0 bgt.s incx6 2 neg d5 d5 = abs(x2-x1) 4 cmp d5,d2 x major or y major ? 6 bgt.s case63 y major/decrement x 8 * * x major/dec x * * rule: always decrement x / maybe increment y * case64 tst d5  10 beq.s loop64 12 swap d2 d2 = [(y2-y1) : 0 ] 14 clr d2 16 divu d5,d2 d2 = (y2-y1)/(x2-x1) 18 bvc.s loop64 20 moveq #-1,d2 22 loop64 tst d4 if bit 7 of pattern is set 24 bpl.s skip64 then skip 26 move.b d0,(a0) else draw ...................28 skip64 subq #1,d5 pixel_count := pixel_count-1 30 blt.s endvec6 32 subq #1,d7 decrement repeatcount 34 bne.s ok64  36 move a5,d7 38 rol #1,d4 40 ok64 subq #1,a0 42 next64 add d2,d3 sum = sum + frac  44 bcc loop64 46 suba a1,a0 inc y 48 bra loop64 50 * * y major / dec x * * rule: always increment y / maybe decrement x * case63 swap d5 52 clr d5 54 divu d2,d5 d5 = frac = (x2-x1)/(y2-y1) 56 bvc.s loop63 58 moveq #-1,d5  60 loop63 tst d4 if bit 7 of pattern is set 62 bpl.s skip63 64 move.b d0,(a0) turn on pixel (x,y) ...........66 skip63 subq #1,d2 pixel_count = pixel_count - 1 68 blt.s endvec6 if pixel_count<0 ;goto endvec 70 subq #1,d7 decrement repeatcount 72 bne.s ok63 74 move a5,d7  76 rol #1,d4 78 ok63 suba a1,a0 increment y 80 add d5,d3 sum = sum + frac 82 bcc loop63 if sum < 1 then goto loop3 84 subq #1,a0 86 bra loop63 88 endvec6 rts 90 incx6 cmp d5,d2 92 bgt.s case61  94 * * x major / inc x * * rule: always increment x / maybe increment y * case62 swap d2 96 clr d2 98 divu d5,d2 d2 = frac 100 bvc.s loop62 102 moveq #-1,d2 104 loop62 tst d4 106 bpl.s skip62  108 move.b d0,(a0) ..............................110 skip62 subq #1,d5 112 blt.s endvec6 114 subq #1,d7 decrement repeatcount 116 ;  bne.s ok62 118 move a5,d7 120 rol #1,d4 122 ok62 addq #1,a0 124 next62 add d2,d3 sum = sum + frac 126 bcc loop62 128 suba a1,a0 130 bra loop62 132 * * y major / inc x * * rule: maybe inc x / always inc y * case61 swap d5 134 clr d5 136 divu d2,d5 138 bvc.s loop61  140 moveq #-1,d5 142 loop61 tst d4 144 bpl.s skip61 146 move.b d0,(a0) ..............................148 skip61  subq #1,d2 150 blt.s endvec6 152 subq #1,d7 decrement repeatcount 154 bne.s ok61 156 move a5,d7  158 rol #1,d4 160 ok61 suba a1,a0 162 add d5,d3 164 bcc loop61  166 addq #1,a0 168 bra loop61 170 page waitcatready equ * assumes a0=deviceaddress SFB btst #0,catseye_status+1(a0)  SFB bne waitcatready rts * * procedure area_fill(gcb:anyptr); * * * local temporaries * ybegin equ rgltemp1 yend equ rgltemp2 left_side equ addr3 ptable equ addr1 stable equ addr2 n  equ n3 gle_aras_out_rpolygon equ * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device_rec ptr move.l info2(gle_gcb),d0 ck for solid fill cmp polygon_solid_fill(gle_gcb),d0 ignor call if not solid bne rts move.l info_ptr1(gle_gcb),addr1(rgl_gcb) move.l info_ptr2(gle_gcb),addr2(rgl_gcb) move clip_limits_ymin+2(gle_gcb),d0 make sure clip limits cmp clip_limits_ymax+2(gle_gcb),d0 allow something bgt rts move clip_limits_xmin+2(gle_gcb),d0 cmp clip_limits_xmax+2(gle_gcb),d0 bgt rts move area_draw_mode(rgl_gcb),d0 lsl #3,d0 cmpi.b #3,devicetype+1(rgl_gcb) ck for 36c beq.s afc blt.s af_packed cmpi.b #5,devicetype+1(rgl_gcb) ck for gatorbox beq.s afc cmpi.b #10,devicetype+1(rgl_gcb) ck for WOODCUT CFB - 24JUL91 bge.s afc CFB - 24JUL91 bra.s af_com Gator, don't do anything af_packed jmp pickamode1(d0) pickamode1 lea fill_dom,a5 bra af2 lea fill_erase,a5 bra af2 lea fill_ndom,a5 bra af2 lea fill_erase,a5 bra.s af2 afc jmp pickamode2(d0) pickamode2 lea f36c_dom,a5 bra af2 lea f36c_erase,a5 bra af2 lea f36c_ndom,a5 bra af2 lea f36c_erase,a5 af_com equ * af2 movea.l ptable(rgl_gcb),a0 a0 = address of end points movea.l stable(rgl_gcb),a1 a1 = address of work area movea #32767,a3 a3 = minimum y moveq #-1,d7 d7 = maximum y clr n(rgl_gcb) segmentloop move.l (a0)+,d0 d0 = n for this segment add d0,< n(rgl_gcb) add this n to ntotal movea.l a0,a2 buildloop move.l (a0)+,d2 move.l (a0)+,d3 (d2,d3) = (xi,yi) subq #1,d0 decrement # of points bne.s buildnorm  last point ? exg a0,a2 yes: wrap around to x1,y1 buildnorm move.l (a0),d4 movea.l d4,a6 cmpa a6,a6 bne int_ovflow move.l 4(a0),d5 movea.l d5,a6 cmpa a6,a6 bne int_ovflow  movea.l dev_dep_stuff(gle_gcb),rgl_gcb restore a6 cmp d3,d5 is y1 <= y2 ? bge.s y2big exg d3,d5 exg d2,d4 (d2,d3) = point with smaller y y2big cmp clip_limits_ymin+2(gle_gcb),d3 bge.s no_clip cmp clip_limits_ymin+2(gle_gcb),d5 blt.s divok y is out of range: build entry move d4,d1 d1 = x2 sub d2,d1 d1=x2-x1 bvs  int_ovflow move d3,d6 d6 = y1 sub clip_limits_ymin+2(gle_gcb),d6 d6 = ymin-y1 bvs int_ovflow neg d6 muls d6,d1 d5=(x2-x1)(ymin-y1) move d5,d6  d6=y2 sub d3,d6 d6=y2-y1 bvs int_ovflow divs d6,d1 d1=(x2-x1)(ymin-y1)/(y2-y1) add d1,d2 d1=x1+(x2-x1)(ymin-y1)/(y2-y1) move clip_limits_ymin+2(gle_gcb),d3 y1=ymin no_clip cmp a3,d3 a3 = min(y1,ymin) bge.s buildm movea d3,a3 buildm cmp d5,d7 d7 = max(y2,ymax) bge.s buildn move d5,d7 buildn moveq #0,d1 d1 = flag sub d3,d5 d5 = y2-y1 bvs int_ovflow sub d2,d4 d4 = x2-x1 bvs int_ovflow bge.s x2big neg d4 d4=abs(x2-x1)  addq #2,d1 set "dec x" bit in flag x2big cmp d4,d5 if |x2-x1|>=|y2-y1|;use y major blt.s xmajor otherwise use x major addq #1,d1 set "y major" bit in flag exg d4,d5 d4=max(dx,dy), d5=min(dx,dy) xmajor tst d4 beq.s div2 dx=dy=0 swap d5 d5.l = min(dx,dy):0 clr d5 divu d4,d5  d5 = frac bvc.s divok div2 moveq #-1,d5 if ovflow or div by 0,d5=.99999 divok move d3,(a1)+ stack y1 move d2,(a1)+ stack x1 move d4,(a1)+  stack m,# of pixels in vector addq #2,a1 skip x2 move d5,(a1)+ stack frac move #$8000,(a1)+ stack sum=.5000000 move d1,(a1)+ stack flag  tst d0 n=0 ? bne buildloop no: build next vector movea.l a2,a0 a0 points to next n tst.l (a0) test size of next segment bgt segmentloop  if > 0 then get next segment move a3,ybegin(rgl_gcb) cmp clip_limits_ymax+2(gle_gcb),d7 ble.s saved7 move clip_limits_ymax+2(gle_gcb),d7 saved7 move d7,yend(rgl_gcb) * * at this point, stable has been constructed, and the procedure is * ready to begin area filling. * move ybegin(rgl_gcb),d1 cmp clip_limits_ymax+2(gle_gcb),d1 bgt rts move n_glines(rgl_gcb),d0 subq #1,d0 sub d1,d0 mulu bytesperline(rgl_gcb),d0 movea.l plane1_addr(rgl_gcb),a0 ptr to addr movea.l (a0),a0 adda.l plane1_offset(rgl_gcb),a0 upper right display address move gspacing(rgl_gcb),d5 subq #1,d5 adda.w d5,a0 <  adjust for 16/26 odd addressing add.l a0,d0 move.l d0,left_side(rgl_gcb) page * * generate the x1---x2 pairs for each vector * * new_line equ * build_x movea.l stable(rgl_gcb),a0 movea.l a0,a1 move n(rgl_gcb),d5 * * a0=a1=beginning of this entry bxy_loop move (a0)+,d0 d0 = y1 cmp ybegin(rgl_gcb),d0 beq.s l10 adda #12,a0 skip rest of entry is stable movea.l a0,a1 bra.s nextv l10  move (a0)+,d0 d0 = x1 move (a0)+,d1 d1 = m = # of pixels left - 1 addq #2,a0 skip x2 (it's trash right now) move (a0)+,d2 d2 = frac move (a0)+,d3 d3 = sum move (a0)+,d4 d4 = flag and #3,d4 mask xmaj/ymaj and inc/decx bits add d4,d4 make it an offset jmp bumpxy(d4) bumpxy bra.s majx_incx bra.s nextvector bra.s majx_decx bra.s nextvector majx_incx add d2,d3 sum = frac+sum bcs.s mxdix if sum overflowed: bump y addq #1,d0 inc x2 subq #1,d1 dec m bge majx_incx subq #1,d0 un-do the last increment bra.s nextvector majx_decx add d2,d3 sum = frac+sum bcs.s mxdix subq  #1,d0 dec x2 subq #1,d1 dec m bge majx_decx addq #1,d0 un-do the last decrement bra.s nextvector mxdix sub d2,d3 undo the add which caused carry nextvector subq #1,d1 dec m ; m<0 all pixels filled addq #4,a1 skip over y1,x1 in stable move d1,(a1)+ stack m move d0,(a1)+ stack x2 addq #2,a1 skip over frac move d3,(a1)+ stack new sum lsr #1,d4 set flag active bit true (0) move d4,(a1)+ stack flag nextv subq #1,d5 n=n-1 bgt bxy_loop page * * mvdw_loop this section takes the (x1,x2) pairs for each vector * and uses them to fill the line. the rule is: * (1) move to odd vectors * (2) draw to even vectors * (3) ignore the last y of every vector when performing * rules (1) and (2) * (4) for all vectors which end on the current y, * fill in the vector itself. * mvdw_loop bsr find_min d5,d6 = x1,x2 of leftmost active vector * the vector is marked dead by find_min beq.s fill_point if no points were active, then finish line move d5,d7 save minimum x in d7 movea d6,a2  bsr find_min d5,d6 = x1,x2 of leftmost active vector beq.s fill_point move d7,d0 d0 = x to start filling at move a2,d1 cmp d6,d1 d1 = x to end filling at bgt.s mvdw1 move d6,d1 mvdw1 bsr fill fill the area between the two vectors bra mvdw_loop * when the segments between all vector pairs have been filled, fill * the vector itself if this is the last line on which the vector exists. fill_point movea.l stable(rgl_gcb),a3 move n(rgl_gcb),d7 d7 = number of vectors fill_ptlp move (a3),d2 d2 = y for this vector cmp ybegin(rgl_gcb),d2 is this vector active ? bne.s next_ptlp no tst 4(a3) did the vector expire on this y ? bge.s next_ptlp no move 2(a3),d0 d0 = x1 move 6(a3),d1 d1 = x2 cmp d0,d1 order them: d0=min x, d1=max x bge.s fp01 exg d0,d1 fp01 bsr fill next_ptlp = adda #14,a3 a3 points to next vector in table subq #1,d7 dec n bgt fill_ptlp * * end of line processing * move ybegin(rgl_gcb),d0 cmp yend(rgl_gcb),d0 done ? * bge rts replaced to allow catseye trr disable SFB blt eol_proc SFB cmpi.b #catseye_hrx_display,devicetype+1(rgl_gcb) CFB 10JUN91 bgt rts CFB 10JUN91 cmpi.b #catseye_display,devicetype+1(rgl_gcb) SFB blt rts CFB 12JUN91 movea.l deviceaddress(rgl_gcb),a0 waitcatready assumes this SFB bsr waitcatready wait for previous move to complete SFB move.w #$0,trr_enable(a0) and restore "not trr" SFB bra rts SFB eol_proc movea.l stable(rgl_gcb),a0 move n(rgl_gcb),d7 eol_loop movem (a0),d0-d6 d0 = y *  d1 = x1 * d2 = m * d3 = x2 * d4 = frac * d5 = sum * d6 = flag cmp ybegin(rgl_gcb),d0 bne.s next_eol tst d2 did y expire ? blt.s next_eol yes, leave y hanging addq #1,d0 inc y and #3,d6 mask of inc/dec bit and x/y major bit add d6,d6 add d4,d5  sum=frac+sum (sets condition codes) jmp eol_p(d6) eol_p bra.s mx_ix bra.s my_ix bra.s mx_dx my_dx bcc.s save_eol mx_dx subq #1,d3 dec x bra.s save_eol my_ix bcc.s save_eol mx_ix  addq #1,d3 inc x save_eol move d3,d1 put new x into x1 movem d0-d5,(a0) put stuff back in table next_eol adda #14,a0 point a0 to next entry in table subq #1,d7 dec n bgt eol_loop  addq #1,ybegin(rgl_gcb) movea.l left_side(rgl_gcb),a0 suba bytesperline(rgl_gcb),a0 move.l a0,left_side(rgl_gcb) bra new_line page * * find_min * find_min movea.l stable(rgl_gcb),a0 move n(rgl_gcb),d0  moveq #0,d1 d1=flag for found anything move ybegin(rgl_gcb),d2 move #32767,d5 d5=xmin find_loop cmp (a0),d2 bne.s next_find ignore vectors whose y does not match tst 4(a0) check m for an expired vector blt.s next_find ignore expired vectors tst 12(a0) blt.s next_find ignore "dead" vectors move 2(a0),d3 d3=x1 move 6(a0),d4 d4=x2 cmp d3,d4 put smaller x in d3 bgt.s  find_1 exg d3,d4 find_1 cmp d5,d3 bgt.s next_find new x is not <= than xmin * (note: it is important to use blt * instead of ble to prevent missing a point)  movea.l a0,a1 remember where this vector was move d3,d5 move d4,d6 (d5,d6) are the minx line addq #1,d1 set found flag next_find adda #14,a0 a0 points to next entry in stable subq #1,d0  dec n bgt find_loop tst d1 set condition codes to indicate whether * or not a vector was found. z=0 means * nothing found. beq.s fm_rts ori  #$8000,12(a1) set "dead" flag. this instruction also * sets the z condition code to indicate * a non-zero result. fm_rts rts page * * fill * * description: this routine fills the area between the points x1 and x2. * the fill is accomplished using a dither pattern, selected * by red_intensity, green_intensity, and blue_intensity. * * entry: d0.w = x1 * d1.w = x2=  (must be >= x1) * gle_gcb = gcb_ptr * left_side = address of left margin of graphics memory * ybegin = y associated with left_side * red_intensity = mode/color of fill *  green_intensity * blue_intensity * gspacing = 1 for all graphics except 9826a * = 2 for 9826a internal screen * devicetype = 0 for 9826a *  1 for 9836a * 2 for 98627a * 3 for 9836c * 4 for gator_bw * 5 for gatorbox - SFB NOV 84 *  6 for bobcat - SFB NOV 84 * 7 for bobcatlores - SFB NOV 84 * 8 for catseye_lcc - SFB MAR 88 * 9 for catseye_hrx - SFB MAR 88 *  10 for woodcut_vga - CFB - 31MAY91 * 11 for woodcut_med - CFB - 31MAY91 * 12 for woodcut_hrx - CFB - 31MAY91 * 13 for woodcut_vgam - CFB - 30JUL91 * 14 for woodcut_hrxm - CFB - 30JUL91 * clip_limits_xmin+2(gcb) = clip boundary for left side of screen * clip_limits_xmax+2(gcb) = clip boundary for right side of screen * * exit: graphics memory is updated * * registers: a0-a2,d0-d5 * no others may be used ! * fill cmp clip_limits_xmin+2(gle_gcb),d0 clip x1 bge.s fill10 move clip_limits_xmin+2(gle_gcb),d0 fill10 cmp clip_limits_xmax+2(gle_gcb),d1 ble.s fill20 move clip_limits_xmax+2(gle_gcb),d1 fill20 cmp d0,d1 blt fm_rts cmpi.b #10,devicetype+1(rgl_gcb) WOODCUT doesn't look like BOBCAT bge fill30 CFB - 24JUL91 cmpi.b #6,devicetype+1(rgl_gcb) bge fbobcat fill30 move blu_intensity(rgl_gcb),d2 movea.l left_side(rgl_gcb),a0 move d0,d3 move d1,d4 ext.l d0 ext.l d1 cmpi.b #3,devicetype+1(rgl_gcb) beq f36c cmpi.b #4,devicetype+1(rgl_gcb) gator - use bitmover beq fgator cmpi.b #5,devicetype+1(rgl_gcb) check gatorbox * can't use tiler for gatorbox (sigh) beq f36c cmpi.b #10,devicetype+1(rgl_gcb) CFB 10JUN91 bge f36c WOODCUT has no window mover CFB 10JUN91 * HOW CAN THIS EVER BE TRUE ??????? - CFB cmpi.b #6,devicetype+1(rgl_gcb) bobcat - use windowmover * but CAN use windowmover (height = 1 pixel) for bobcat bge fbobcat * 9826a/16a,36a,98627a all come here lsr #3,d0 lsr #3,d1 and #7,d3 and #7,d4 sub d0,d1 d0=# of bytes to do - 1 addq #1,d4 adda d0,a0 a0 points to first byte to modify tst devicetype(rgl_gcb) 9816 or 9826 ? bne.s fill40 adda d0,a0 on 9826 & 9816 have to add it twice fill40 btst #1,devicetype+1(rgl_gcb)  is this color ? beq.s f26a36a no f27a movea.l a0,a1 movea.l a0,a2 a0/a1/a2 point to blue plane adda.l plane2_offset(rgl_gcb),a1 a1 points to green plane adda.l plane3_offset(rgl_gcb),a2 a2 points to red plane move.l a1,-(sp) save a1 for later move d1,-(sp) save the byte count (d1) bsr.s fill_plane fill the blue plane move (sp)+,d1 restore the byte count  move grn_intensity(rgl_gcb),d2 movea.l (sp)+,a0 a0 points to green plane move d1,-(sp) bsr.s fill_plane move (sp)+,d1 move red_intensity(rgl_gcb),d2 movea.l a2,a0 a0 points to red > plane bra.s fill_plane fill the red plane (fill_p does rts) f26a36a cmp grn_intensity(rgl_gcb),d2 find maximum fill color bgt.s f26a36a10 move grn_intensity(rgl_gcb),d2 f26a36a10 cmp red_intensity(rgl_gcb),d2 bgt.s fill_plane move red_intensity(rgl_gcb),d2 bra.s fill_plane dither_table dc.l $00000000 0 dc.l $88000000 1 dc.l $88002200 2 dc.l $8800aa00 3 dc.l $aa00aa00 4 dc.l $aa44aa00 5 dc.l $aa44aa11 6 dc.l $aa44aa55 7 dc.l $aa55aa55 8 dc.l $aaddaa55 9 dc.l $aaddaa77 10 dc.l $aaddaaff 11 dc.l $aaffaaff 12 dc.l $eeffaaff 13 dc.l $eeffbbff 14 dc.l $eeffffff 15 dc.l $ffffffff 16 fill_plane and #$1f,d2 lsl #2,d2 move ybegin(rgl_gcb),d5 and #3,d5 mask off right two bits add d5,d2 move.b dither_table(d2),d2 jmp (a5) fill_dom tst d1 how many bytes are effected ? bne.s fd10 more than one rol d4,d2 rol.w x2b+1,mask move.b (a0),d2 g->mask.b rol.b d4,d2 rol  d3,d2 ror d4,d2 ror.w x2b-x1b+1,mask ror.b d3,d2 move.b d2,(a0) mask->g rts fd10 movea gspacing(rgl_gcb),a1 move.b (a0),d0 rol d3,d0 move.b d2,d0 rol.b d3,d0  ror d3,d0 move.b d0,(a0) adda.l a1,a0 subq #2,d1 blt.s fd30 fd20 move.b d2,(a0) adda.l a1,a0 dbra d1,fd20 fd30 rol d4,d2 move.b (a0),d2 rol.b d4,d2 ror d4,d2 move.b d2,(a0) rts fill_ndom tst d1 how many bytes are effected ? bne.s fn10 more than one rol d4,d2 rol.w x2b+1,mask move.b (a0),d2 g->mask.b rol.b d4,d2 rol d3,d2 ror d4,d2 ror.w x2b-x1b+1,mask ror.b d3,d2 or.b d2,(a0) mask->g rts fn10 movea gspacing(rgl_gcb),a1 move.b (a0),d0 rol d3,d0 move.b d2,d0 rol.b d3,d0 ror d3,d0 or.b d0,(a0) adda.l a1,a0 subq #2,d1 blt.s fn30 fn20 or.b d2,(a0) adda.l a1,a0 dbra d1,fn20 fn30 rol d4,d2 move.b (a0),d2 rol.b d4,d2  ror d4,d2 or.b d2,(a0) rts fill_erase not.b d2 tst d1 how many bytes are effected ? bne.s fe10 more than one rol d4,d2 rol.w x2b+1,mask move.b (a0),d2 g->mask.b rol.b d4,d2 rol d3,d2 ror d4,d2 ror.w x2b-x1b+1,mask ror.b d3,d2 and.b d2,(a0) mask->g rts fe10 movea gspacing(rgl_gcb),a1 move.b (a0),d0 rol d3,d0 move.b d2,d0 rol.b d3,d0 ror d3,d0 and.b d0,(a0) adda.l a1,a0 subq #2,d1 blt.s fe30 fe20 and.b d2,(a0) adda.l a1,a0 dbra d1,fe20 fe30 rol d4,d2 move.b (a0),d2 rol.b d4,d2 ror d4,d2 and.b d2,(a0) rts f36c and #3,d0 x1 mod 4 and #3,d1 x2 mod 4 lsl #2,d0 (x1 mod 4)*4 # of bytes to jump in mask lsl  #2,d1 (x2 mod 4)*4 # of bytes to jump in mask and #$fffc,d3 x1 div 4 adda d3,a0 a0 points to first nibble that changes lsr #2,d3 # of nibbles to x1 lsr #2,d4 # of nibbles to x2 sub d3,d4 # of nibbles to do -1 move d4,d3 move ybegin(rgl_gcb),d5 and.l #3,d5 lsl #2,d5 move.l dither_pattern(rgl_gcb,d5),d2 move.l d2,d5 move.l mask1(d0),d4 jmp >  (a5) mask1 dc.l $ffffffff dc.l $00ffffff dc.l $0000ffff dc.l $000000ff mask2 dc.l $ff000000 dc.l $ffff0000 dc.l $ffffff00 dc.l $ffffffff f36c_dom tst d3 bne.s fcd10 fcd05 and.l mask2(d1),d4 moveq #0,d3 fcd10 and.l d4,d5 not.l d4 and.l d4,(a0) or.l d5,(a0)+ dbra d3,fcd20 rts fcd20 moveq #-1,d4 move.l d2,d5 tst d3 beq.s fcd05 subq #1,d3 fcd30 move.l d2,(a0)+ dbra d3,fcd30 bra.s fcd05 f36c_ndom tst d3 bne.s fcn10 fcn05 and.l mask2(d1),d4 moveq #0,d3 fcn10 and.l d2,d4 or.l d4,(a0)+ dbra d3,fcn20 rts fcn20 moveq #-1,d4 tst d3 beq.s fcn05 subq #1,d3 fcn30 or.l d2,(a0)+ dbra d3,fcn30 bra.s fcn05 f36c_erase not.l d2 tst d3 bne.s fce10 fce05 and.l mask2(d1),d4 moveq #0,d3 fce10  and.l d5,d4 not.l d4 and.l d4,(a0)+ dbra d3,fce20 rts fce20 moveq #-1,d4 tst d3 beq.s fce05 subq #1,d3 fce30 and.l d2,(a0)+ dbra d3,fce30 bra.s fce05 *fill_comp tst  d3 * bne.s fc10 *fc05 and.l mask2(d1),d4 *fc10 and.l d4,d5 * eor.l d5,(a0)+ * dbra d3,fc20 * rts *fc20 move.l mask1,d4 * move.l d2,d5 *fc30 tst d3 * beq.s fc05 * eor.l d2,(a0)+ * dbra d3,fc30 * rts page fgator movea.l plane1_addr(rgl_gcb),a2 movea.l (a2),a2 adda.l plane1_offset(rgl_gcb),a2 upper right display address adda.l #$0ff000,a2 move ybegin(rgl_gcb),d5 and #3,d5 y mod 4 lsl #5,d5 lsl #5,d5 1024*(y mod 4) adda d5,a2 a2 points to dither pat. sub d4,d3  -(number of pixels)-1 subq #1,d3 -(number of pixels) fgat10 movea.l old_a5(gle_gcb),a1 movea.l status(a1),a1 btst #7,1(a1) beq.s fgat10 movea.l old_a5(gle_gcb),a1  move.w d3,wwcopy(a1) update current window width movea.l window(a1),a1 set window width move.w d3,(a1) move.w #$83,d3 movea.l old_a5(gle_gcb),a1 move.w d3,rrcopy(a1) movea.l rule(a1),a1 move.w d3,(a1) move.b 0(a2,d0),0(a0,d0) move line fgat11 movea.l old_a5(gle_gcb),a1 movea.l status(a1),a1 btst #7,1(a1) beq.s fgat11 move.w #$3,d3 movea.l old_a5(gle_gcb),a1 move.w d3,rrcopy(a1) movea.l rule(a1),a1 move.w d3,(a1) rts fbobcat equ * SFB FEB '85 movea.l old_a5(gle_gcb),a1 access to globals movea.l status(a1),a1 windowmover status reg * now fill the scanline segment by moving a section of the fill pattern stored * in bottom 4 lines of (offscreen) frame buffer to displayed line segment * to be filled. The source segment is computed mod 4 because we use a 4x4 * dither cell. The window mover is set to 1 pixel high, so we can treat it * like a gator line mover. cmpi.b #bobcat_lores_display,devicetype+1(rgl_gcb) bne.s waitbobmover add.w d0,d0 double startx for "real" pixels add.w d1,d1 double endx for "real" pixels addq #1,d1 {3.1E BUG SFB 6/14/85}and go to right edge of pixel waitbobmover equ * move.w (a1),d5 lsr #8,d5 status in even byte * IS THIS A BUG ???? SFB * and.w  gamut(gle_gcb),d5 check only loaded topcats and.w gamut+2(gle_gcb),d5 check only loaded topcats beq.s bobmover_done move.l #1,-(sp) not ready, so wait before jsr delay_timer ?  testing mover status again bra.s waitbobmover bobmover_done equ * movea.l deviceaddress(rgl_gcb),a1 base for graphics control move.w d0,sox(a1) source x move.w d0,dox(a1) destination x move.w ybegin(rgl_gcb),d5 move.w hard_ymax(rgl_gcb),d2 prepare to reverse sign of y sub.w d5,d2 convert ybegin to pixelline move.w d2,doy(a1) destination y and.w #3,d5  dest y mod 4 movep.w $9(a1),d2 height of visible buffer (ROM) sub.w #4,d2 move up 4 lines from bottom add.w d2,d5 access one of last 4 lines move.w d5,soy(a1)  source y (within fill pattern) move.w #1,bobh(a1) height (1 pixel) sub.w d0,d1 width-1 (real pixels) addq #1,d1 width (real pixels) move.w d1,bobw(a1)  width move.l gamut(gle_gcb),d5 move all planes lsl #8,d5 cmpi.b #catseye_display,devicetype+1(rgl_gcb) SFB bge.s fcatseye SFB move.w #3,bobwr(a1) windowmove replacement rule move_scanline equ * move.w d5,bobwm(a1) rts DONE-don't wait for it to * complete (DGL owns the *  bobcat windowmover resource) fcatseye equ * move.w #$100,trr_enable(a1) select Three Operand Repl Rule SFB move.w #$f000,trr(a1) choose "Pattern Reg" rule SFB move.w d5,fben1(a1) enable all loaded planes SFB bra move_scanline SFB page **************************************************************************** * * cursor ( gcb : graphics_control_block_ptr ) * * INFO1 - X location * INFO2 - Y location * INFO3 - Mode ( 0 = off, 1 = on ) * gle_aras_out_rcursor equ * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = dev_dep_gcb cmpi.w #1,current_cursor_state(gle_gcb) bne.s curs1 move.w current_cursor_x+2(gle_gcb),cursor_x(rgl_gcb) remove current cusor move.w current_cursor_y+2(gle_gcb),cursor_y(rgl_gcb) bsr.s cursor_p curs1 equ * cmpi.l #1,info3(gle_gcb) bne.s curs2 move.w info1+2(gle_gcb),cursor_x(rgl_gcb) draw new cursor move.w info2+2(gle_gcb),cursor_y(rgl_gcb) bsr.s cursor_p curs2 equ * move.l info1(gle_gcb),current_cursor_x(gle_gcb) move.l info2(gle_gcb),current_cursor_y(gle_gcb) move.w info3+2(gle_gcb),current_cursor_state(gle_gcb) bra rts * * * the cursor_x and cursor_y will be in system * units, ie., from 0..hard_xmax and * 0..hard_ymax. the set_x routine changes * to actual hardware addresses. * cursor_p equ * movea.l plane2_offset(rgl_gcb),a2 green plane movea.l plane3_offset(rgl_gcb),a3 red plane movea.l plane1_addr(rgl_gcb),a1 blue plane  movea.l (a1),a1 adda.l plane1_offset(rgl_gcb),a1 upper right display address move devicetype(rgl_gcb),d6 cmpi.b #gator_display,devicetype+1(rgl_gcb) gator/box/bobcat * bne.s skp_notgat  -- reset d6 like 36c blt.s skp_notgat move #3,d6 skp_notgat tst d6 bne.s cp1 adda.l #1,a1 9826/16 inc cp1 move bytesperline(rgl_gcb),d5 move hard_ymax(rgl_gcb),d3 muls d5,d3 adda.l d3,a1 address of lower left move gspacing(rgl_gcb),d7 ext.l d5 ext.l d7 clr.l d3 clr.l d4 * clip the cursor first: c10 movea.l a1,a5 move cursor_x(rgl_gcb),d0 ?  cmpi #4,d0 is center <4 from left edge? blt clip_left move hard_xmax(rgl_gcb),d1 subq #4,d1 cmp d1,d0 is center >4 from right edge? bgt clip_right subq #4,d0  if got here, then fix d0 & d3 move.b #8,d3 c20 move cursor_y(rgl_gcb),d1 cmpi #4,d1 is center <4 from bottom edge? blt clip_bottom move hard_ymax(rgl_gcb),d2 subq #4,d2 cmp d2,d1 bgt clip_top * if the line is unclipped, i.e., we got here, then draw 9 bits: move.b #8,d4 d3 was set to appropriate value move d1,d2 above for vertical calculation addq #4,d2  +4 above curs_y * * at entry: * d0 = x * d1 = y for horizontal line * d2 = y for vertical line * d3 = bits to change in horizontal line - 1 * d4 = bits to change in vertical line - 1 * d5 = number of bytes/line * d6 = crt type 0-9826 1-9836 2-98627 3-9836C/BITMAP * d7 = gspacing * a1 = lower left corner of graphics memory * a2 = plane2_offset * a3 = plane3_offset * * do the horizontal line first, left to right * * | modified to fix cursor bug -- 12/83 BDS draw_horiz equ * cmp hard_ymax(rgl_gcb),d1 bgt draw_vert If cursor_y > max y, skip to vert tst d1 blt draw_vert If cursor_y < 0, skip to vert beq.s  dh20 dh10 mulu d5,d1 suba.l d1,a1 gives y address dh20 bsr set_x dh30 btst #1,d6 beq dh50 btst #0,d6 beq dh40 cmpi.b #7,devicetype+1(rgl_gcb) SFB 6/20/85 beq  dh37 SFB 6/20/85 dh35 not.b (a1)+ dbra d3,dh35 bra.s draw_vert dh37 not.w (a1)+ SFB 6/20/85 dbra d3,dh37 SFB 6/20/85 bra.s draw_vert SFB 6/20/85 dh40 bchg d0,0(a1,a2.l) bchg d0,0(a1,a3.l) dh50 bchg d0,(a1) dh60 dbra d3,dh65 d3=no. of bits to change bra.s draw_vert dh65 subq.b #1,d0 cmpi.b #0,d0 are we at end of byte? bge.s dh30  goto dh30 if not adda.l d7,a1 increment to next byte moveq #7,d0 start changing bit 7 of next byte dh70 btst #1,d6 beq dh90 dh80 bchg d0,0(a1,a2.l) bchg d0,0(a1,a3.l) dh90 bchg d0,(a1) subq.b #1,d0 dbra d3,dh70 * do vertical line next, top to bottom: * | modified to fix cursor bug -- 12/83 BDS draw_vert equ * move cursor_x(rgl_gcb),d0 vert. line draw at x=cursor_x blt.s dv70 if x < 0, skip vert line cmp hard_xmax(rgl_gcb),d0 bgt.s dv70 if x > max x, skip vert line tst d2 beq.s dv20 dv10 mulu d5,d2 suba.l d2,a5 dv20 movea.l a5,a1  bsr set_x d0=bit dv30 btst #1,d6 beq dv50 btst #0,d6 beq dv40 cmpi.b #7,devicetype+1(rgl_gcb) SFB 6/20/85 beq dv37 SFB 6/20/85 dv35 not.b (a1) adda.l d5,a1 dbra d4,dv35 rts dv37 not.w (a1) SFB 6/20/85 adda.l d5,a1 SFB 6/20/85 dbra d4,dv37 SFB 6/20/85 rts dv40 bchg d0,0(a1,a2.l) bchg d0,0(a1,a3.l) dv50 bchg d0,(a1) dv60  adda.l d5,a1 sub n bytes/row from a1 dbra d4,dv30 dv70 rts if d4=-1, we are done * * set_x equ * move d0,d1 cmpi.b #3,devicetype+1(rgl_gcb) bge.s sx10 lsr #3,d1 tst devicetype(rgl_gcb) bne.s sx10 lsl #1,d1 sx10 adda d1,a1 cmpi.b #7,devicetype+1(rgl_gcb) SFB 6/20/85 bne sx20 adda d1,a1 "real" pixels SFB 6/20/85 sx20 andi.l #7,d0 n@ eg d0 addq #7,d0 rts * * | modified to fix cursor bug -- 12/83 BDS clip_left equ * * at entry, d0 contains cursor_x move d0,d3 addq #4,d3 draw cursor_x + 5 dots bge.s cl10 draw no less than 0 dots moveq #0,d3 cl10 moveq #0,d0 new x bra c20 * * | modified to fix cursor bug -- 12/83 BDS clip_right equ * * at entry, d1 contains bits_in_y minus 4; * d0 contains cursor_x addq  #4,d1 d1 = hard_xmax move d1,d3 d3 = hard_xmax subq #4,d0 d0 = cursor_x - 4 (start of line) sub d0,d3 d3 = # of dots (xmax-start of line) bge c20  if start of line > x max move d1,d0 start of line = xmax moveq #0,d3 # of dots = 0 bra c20 * * | modified to fix cursor bug -- 12/83 BDS clip_bottom equ * * at entry, d0 contains proper x value for the horizontal line, and * d1 contains proper y value for the horizontal line. move d1,d2 addq #4,d2 y for vertical line bge.s cb20 if y < 0 then  moveq #0,d2 y = 0 cb20 move d2,d4 number of bits to draw = y bra draw_horiz * * | modified to fix cursor bug -- 12/83 BDS clip_top equ * * at entry, d0 and d1 contain the proper x and y values for the horizontal, * d1 contains cursor_y. * d2 contains bits_in_y minus 4. sub d1,d2 d2 - curs_y addi #8,d2 number of bits to draw bge.s ct10 if # of bits < 0 then moveq #0,d2 # of bits = 0 ct10 move d2,d4 move hard_ymax(rgl_gcb),d2 new y bra draw_horiz * * * dump graphics expanded * *gdump_exp equ * *movea.l 4(sp),a0 a0 = address of pointer to gcb *move.l (sp)+,(sp) stack return address *movem.l a5-a6,old__a5(a0) *movea.l a0,a6 a6 = address of pointer to gcb *move n_glines(rgl_gcb),d3 d3 = number of graphics lines *subq #1,d3 d3 = d3-1 *move bytesperline(rgl_gcb),d4 d4 = bytes/line *movea.l lower_left(rgl_gcb),a1 a1 = address of lower left *movea.l addr1(rgl_gcb),a0 a0 = address of string *move.l index(rgl_gcb),d0  d0 = number of line to be dumped *bsr set_x *moveq #7,d2 *move devicetype(rgl_gcb),d1 *add d1,d1 *jmp getable(d1) *getable bra.s ge26a *bra.s ge26a 36a same as 26a *bra.s ge27a *bra.s ge36c * *ge26a move.b (a1),d5 *btst d0,d5 *beq.s ge26a10 *bset d2,(a0) *subq.b #1,d2 *bset d2,(a0) *subq.b #1,d2 *bra.s ge26a20 *ge26a10 bclr d2,(a0) *subq.b #1,d2 *bclr d2,(a0) *subq.b #1,d2 *ge26a20 bge.s ge26a30 *adda #1,a0 *moveq #7,d2 *ge26a30 suba d4,a1 *dbra d3,ge26a *bra rts * *ge27a bsr getoffsets *ge27a10 move.b (a1),d5 *move.b (a2),d6 *or.b d5,d6 *move.b (a3),d5 *or.b d5,d6 *btst d0,d6 *beq.s ge27a20 *bset d2,(a0) *subq.b #1,d2 *bset d2,(a0) *subq.b #1,d2 *bra.s ge27a30 *ge27a20 bclr d2,(a0) *subq.b #1,d2 *bclr d2,(a0) *subq.b #1,d2 *ge27a30 bge.s ge27gle_gcb0 *adda #1,a0 *moveq #7,d2 *ge27gle_gcb0 suba d4,a1 *suba d4,a2 *suba d4,a3 *dbra d3,ge27a10 *bra rts *ge36c cmpi.b #0,(a1) *beq.s ge36c10 *bset d2,(a0) *subq.b #1,d2 *bset d2,(a0) *subq.b #1,d2 *bra.s ge36c20 *ge36c10 bclr d2,(a0) *subq.b #1,d2 *bclr d2,(a0) *subq.b #1,d2 *ge36c20 bge.s ge36c30 *adda #1,a0 *moveq #7,d2 *ge36c30 suba d4,a1 *dbra d3,ge36c *bra rts * ******************************************************************************* gr26a moveq #50,d0 50 bytes/line; 1 dumped at a time@  move.l info1(gle_gcb),d5 test for dump flag bit 0 = 1 or beq.s gr26a20 dump flag = 0 btst #0,d5 bne.s gr26a20 moveq #0,d1 bra.s gr26a20c gr26a10c move.b d1,(a0)+ set to zero's gr26a20c dbra d0,gr26a10c bra rts gr26a10 move.b (a1),(a0)+ dump normal addq #2,a1 gr26a20 dbra d0,gr26a10 bra rts * * GET_RASTER ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); * * Return formated packed array of char for dump graphics * * INFO_PTR1 = Start of packed array of char * INFO1 = Which planes to 'or' * INFO2 = Graphics line # to convert (0 = top of crt) * gle_aras_out_rget_raster equ * movea.l 4(sp),gle_gcb  a4 = address of pointer to gcb move.l (sp)+,(sp) movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = dev dep gcb movea.l info_ptr1(gle_gcb),a0 a0 = address of string movea.l plane1_addr(rgl_gcb),a1 movea.l (a1),a1 adda.l plane1_offset(rgl_gcb),a1 upper right address move.l info2(gle_gcb),d0 d0 = row to be dumped mulu bytesperline(rgl_gcb),d0 d0 = row * bytes/line adda.l d0,a1  a1 = address of line dumped move devicetype(rgl_gcb),d1 cmpi.b #gator_display,devicetype+1(rgl_gcb) * bne.s skp_notgat2 SFB NOV 84 blt.s skp_notgat2 SFB NOV 84 move #3,d1  gator/gatorbox/bobcat -- set d1 to 36c skp_notgat2 add d1,d1 jmp grtable(d1) grtable bra.s gr26a bra.s gr36a bra.s gr27a bra.s gr36c gr36a moveq #16,d0 64 bytes/line; 4 dumped at a time  move.l info1(gle_gcb),d5 test for dump flag bit 0 = 1 or beq.s gr36a20 dump flag = 0 btst #0,d5 bne.s gr36a20 moveq #0,d1 bra.s gr36a20c gr36a10c move.l d1,(a0)+ dump zeros gr36a20c dbra d0,gr36a10c bra rts gr36a10 move.l (a1)+,(a0)+ dump normal gr36a20 dbra d0,gr36a10 bra rts gr27a bsr getoffsets moveq #16,d0 64 bytes/line; 4 dumped at a time move.l info1(gle_gcb),d5 get mask bra.s gr27a20 gr27a10 moveq #0,d3 move.l (a1)+,d1 btst #0,d5 beq.s gr1 move.l d1,d3 gr1 move.l (a2)+,d1 btst #1,d5 beq.s gr2 or.l d1,d3 gr2 move.l (a3)+,d1 btst #2,d5 beq.s gr3 or.l d1,d3 gr3 move.l d3,(a0)+ gr27a20 dbra d0,gr27a10 bra rts gr36c moveq #63,d0 64 bytes/line; 1 dumped at a time (-1) gr36c10 moveq #7,d1  moveq #0,d2 gr36c20 move.b (a1)+,d3 and.b info1+3(gle_gcb),d3 cmpi.b #0,d3 beq.s gr36c30 bset d1,d2 gr36c30 dbra d1,gr36c20 move.b d2,(a0)+ dbra d0,gr36c10 bra rts * * * *gstore_proc equ * *movea.l 4(sp),a0 a0 = address of pointer to gcb *move.l (sp)+,(sp) stack return address *movem.l a5-a6,old__a5(a0) *movea.l a0,a6 a6 = address of pointer to gcb *movea.l addr1(rgl_gcb),a0  a0 = address of array *move.l index(rgl_gcb),d0 d0 = size of array in words *movea.l plane1_addr(rgl_gcb),a1 a1 = ptr to address of plane 1 *movea.l (a1),a1 a1 = address of plane 1 *adda.l plane1_offset(rgl_gcb),a1 upper right address *move gspacing(rgl_gcb),d1 *subq #1,d1 *adda.w d1,a1 adjust for 16/26 odd adr *move devicetype(rgl_gcb),d1 *add d1,d1 *jmp gstable(d1) *gstable bra.s gs26a *bra.s gs36a *bra.s gs27a *bra.s gs36c * *gs26a add.l d0,d0 *bra.s gs26a20 *gs26a10 move.b (a1),(a0)+ *addq #2,a1 *gs26a20 dbra d0,gs26a10 *bra rts * *gs36a bra.s gs36a20 *gs36a10 move (a1)+,(a0)+ *gs36a20 dbra d0,gs36A a10 *bra rts * *gs27a divu #3,d0 *move.l d0,d1 *swap d1 *bsr getoffsets *bra gs27a20 *gs27a10 move (a1)+,(a0)+ *move (a2)+,(a0)+ *move (a3)+,(a0)+ *gs27a20 dbra d0,gs27a10 *sub.b #1,d1 *blt rts *move (a1)+,(a0)+ *sub.b #1,d1 *blt rts *move (a2)+,(a0)+ *sub.b #1,d1 *blt rts *move (a3)+,(a0)+ *bra rts * *gs36c lsr.l #1,d0 *bra.s gs36c20 *gs36c10 move.l (a1)+,d2 *ror.l #4,d2 *or.l (a1)+,d2 *rol.l #4,d2 *move.l d2,(a0)+ *gs36c20 dbra d0,gs36c10 *bra rts * ** ** * *gload_proc equ * *movea.l 4(sp),a0 a0 = address of pointer to gcb *move.l (sp)+,(sp) stack return address *movem.l a5-a6,old__a5(a0) *movea.l a0,a6  a6 = address of pointer to gcb *movea.l addr1(rgl_gcb),a0 a0 = address of array *move.l index(rgl_gcb),d0 d0 = size of array in words *movea.l plane1_addr(rgl_gcb),a1 a1 = ptr to address of plane 1 *movea.l (a1),a1 a1 = address of plane 1 *adda.l plane1_offset(rgl_gcb),a1 upper right address *move gspacing(rgl_gcb),d1 *subq #1,d1 *adda.w d1,a1 adjust for 16/26 odd adr *move devicetype(rgl_gcb),d1 *add d1,d1 *jmp gltable(d1) *gltable bra.s gl26a *bra.s gl36a *bra.s gl27a *bra gl36c * *gl26a moveq #48,d1 *divu #12,d0 *bra.s gl26a20 *gl26a10 movem.l (a0)+,d2-d7 *movep.l d2,$0(a1) *movep.l d3,$8(a1) *movep.l d4,$10(a1) *movep.l d5,$18(a1) *movep.l d6,$20(a1) *movep.l d7,$28(a1) *adda d1,a1 *gl26a20 dbra d0,gl26a10 *swap d0 *add d0,d0 *bra.s gl26gle_gcb0 *gl26a30 move.b (a0)+,(a1) *addq #2,a1 *gl26gle_gcb0 dbra d0,gl26a30 *bra rts * *gl36a moveq #40,d1 *divu #20,d0 *bra.s gl36a20 *gl36a10 movem.l (a0)+,d2-d7/a2-a5 *movem.l d2-d7/a2-a5,(a1) *adda d1,a1 *gl36a20 dbra d0,gl36a10 *swap d0 *bra.s gl36gle_gcb0 *gl36a30 move (a0)+,(a1)+ *gl36gle_gcb0 dbra d0,gl36a30 *bra rts * *gl27a divu #12,d0 *move.l d0,d1 *swap d1 *bsr getoffsets *bra gl27a20 *gl27a10 move (a0)+,(a1)+ *move (a0)+,(a2)+ *move (a0)+,(a3)+ *move (a0)+,(a1)+ *move (a0)+,(a2)+ *move  (a0)+,(a3)+ *move (a0)+,(a1)+ *move (a0)+,(a2)+ *move (a0)+,(a3)+ *move (a0)+,(a1)+ *move (a0)+,(a2)+ *move (a0)+,(a3)+ *gl27a20 dbra d0,gl27a10 *gl27a30 sub.b #1,d1 *blt rts *move (a0)+,(a1)+ *sub.b #1,d1 *blt  rts *move (a0)+,(a2)+ *sub.b #1,d1 *blt rts *move (a0)+,(a3)+ *bra.s gl27a30 * *gl36c lsr.l #1,d0 *bra.s gl36c20 *gl36c10 move.l (a0)+,d2 *move.l d2,(a1)+ *ror.l #4,d2 *move.l d2,(a1)+ *gl36c20 dbra d0,gl36c10 *bra  rts * ** ** ** getoffsets movea.l a1,a2 movea.l a1,a3 adda.l plane2_offset(rgl_gcb),a2 adda.l plane3_offset(rgl_gcb),a3 rts * *get_size equ * *cmpi.b #2,devicetype+1(rgl_gcb) *beq.s moon *move.l #$6180,t1(rgl_gcb) *move.l #$30C,t2(rgl_gcb) *rts * *moon move.l #$8000,t1(rgl_gcb) *move.l #$400,t2(rgl_gcb) *rts rtarg equ rgltemp1 ract equ rgltemp1+2 gtarg equ rgltemp2 gact equ rgltemp2+2 btarg equ rgltemp3 bact equ rgltemp3+2 serrin equ rgltemp4 serrout equ rgltemp5 red equ red_intensity ************************************************************************* * * PROCEDURE FILL_INDEX_COLOR ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ); * * INFO1 = Parameter mode * 0 - RGB values passed * 1 - Color map index passed * * INFO2 = Normalized RED value or Color index (based on mode) * INFO3 = Normalized GREEN value * INFO4 = Normalized Blue value * gle_aras_out_rfill_index_color equ * * movea.l 4(sp),gle_gcb a4 = gcb move.l (sp)+,(sp) * lea -512(a7),a0 * cmp.l a0,SYSGLOBALS-14(a5) * ble.s stackok * move.w #-2,SYSGLOBALS-2(a5) * A  trap #10 * stackok equ * movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = dev_dep gcb tst.l info1(gle_gcb) ck mode beq.s fill_index2 move.l info2(gle_gcb),d0  get color index move.w d0,current_polygon_color(gle_gcb) moveq #0,d1 fill_index1 move.b d0,dither_pattern(rgl_gcb,d1.l) addq.l #1,d1 cmp #15,d1 ble.s fill_index1 bra rts fill_index2 move.w #-1,current_polygon_color(gle_gcb) move.w info2+2(gle_gcb),d0 red move.w info3+2(gle_gcb),d1 green move.w info4+2(gle_gcb),d2 blue move.w d0,current_polygon_red(gle_gcb) move.w d1,current_polygon_green(gle_gcb) move.w d2,current_polygon_blue(gle_gcb) *cmpi.w #1,color_map_support(gle_gcb) ck for color cmpi.w #3,devicetype(rgl_gcb) beq.s setup_c_dither cmpi.w #gator_display,devicetype(rgl_gcb) //// do same for //// * beq.s setup_c_dither //// gator for now // bge.s setup_c_dither also for gatorbox/bobcat add.w #32,d0 add.w #32,d1 add.w #32,d2 lsr.w #6,d0 lsr.w #6,d1  lsr.w #6,d2 move.w d0,red_intensity(rgl_gcb) move.w d1,grn_intensity(rgl_gcb) move.w d2,blu_intensity(rgl_gcb) bra rts ************************************************************************* * setup_c_dither equ * move.w d0,red_intensity(rgl_gcb) move.w d1,grn_intensity(rgl_gcb) move.w d2,blu_intensity(rgl_gcb) set_intens equ * lea system_cmap(rgl_gcb),a0 suba #768,a7 {SFB 4/12/85} allocate 768 bytes off stack lea 512(a7),a1 use 256 bytes for count array lea 0(a7),a5 and 512 for boolean in/out movem red(a6),d1-d3 lsl #4,d1 d1 = 16*red lsl #4,d2 d2 = 16*grn lsl #4,d3 d3 = 16*blu movea.l a0,a2 a2 = temp address of syscmap move.l gamut(gle_gcb),d0 d0 = loop counter moveq #0,d4 d4 = zero out upper byte si10 clr.b 0(a5,d0) clear boolean move.w (a2),d4 d4 = syscmap.r cmp d4,d1 if syscmap.r>16*red blt.s si20 then outside move.w 2(a2),d4 d4 = syscmap.g cmp d4,d2 if syscmap.g>16*grn blt.s si20 then outside move.w 4(a2),d4 d4 = syscmap.b cmp d4,d3 if syscmap.b>16*blu blt.s si20  then outside move.b #1,0(a5,d0) inside so set boolean si20 addq #6,a2 increment to next syscmap dbra d0,si10 loop clr.l rtarg(a6) clear rtarg and ract clr.l gtarg(a6) clear gtarg and gact clr.l btarg(a6) clear btarg and bact movea.l a1,a3 a3 = count array pointer move.l gamut(gle_gcb),d0 loop counter lsr #2,d0 divide by 4 for long words si30 clr.l (a3)+ clear count array dbra d0,si30 loop moveq #0,d4 zero out upper byte of d4 moveq  #15,d0 pixel loop counter si40 movem red(a6),d5-d7 add d5,rtarg(a6) rtarg=rtarg+red add d6,gtarg(a6) gtarg=gtarg+grn add d7,btarg(a6) btaeg=btarg+blu move.l #$7fffffff,serrin(a6) smallest_err_in=maxint move.l serrin(a6),serrout(a6) smallest_err_out=maxint movea.l a0,a2 syscmap array index moveq #0,d7 in flag move.l gamut(gle_gcb)B ,d1 inner loop counter si50 tst d7 if none in so far beq.s si55 then got to look for one tst.b 0(a5,d1) if this vector is out beq si100  then don't do this stuff si55 move rtarg(a6),d2 sub ract(a6),d2 move.w (a2),d4 get syscmap.r sub d4,d2 d2=rtarg-ract-syscmap.r muls d2,d2 si60 move.l d2,d3  move gtarg(a6),d2 sub gact(a6),d2 move.w 2(a2),d4 get syscmap.g sub d4,d2 d2=gtarg-gact-syscmap.g muls d2,d2 si70 add.l d2,d3 move btarg(a6),d2 sub bact(a6),d2 move.w 4(a2),d4 get syscmap.b sub d4,d2 d2=btarg-bact-syscmap.b muls d2,d2 si80 add.l d2,d3 tst.b 0(a5,d1) if vector not inside beq.s si90  then outside cmp.l serrin(a6),d3 if smallest_err_in<=error bge.s si100 then ignore move.l d3,serrin(a6) smallest_err_in=error move d1,d5 closest_color_in=i moveq #1,d7 in flag bra.s si100 si90 cmp.l serrout(a6),d3 if smallest_err_out<=error bge.s si100 then ignore move.l d1,serrout(a6) smallest_err_out=error move d1,d6 closest_color_out=i si100 addq #6,a2 increment syscmap pointer dbra d1,si50 loop (inner) tst d7 if no vectors were in beq.s si110 then do out stuff move d5,d6 closest_color=closest_color_in si110 move.l gamut(gle_gcb),d5 get number of colormap entries sub d6,d5 real index= entries-i movea d5,a3 a3=closest_color * following is code originally for 4 byte/color map entry (1 byte each for * RGB, and 1 byte pad) * add d5,d5 * movea d5,a2 a2=closest_color * adda d5,a2 a2=4*closest_color * instead, for 6 byte/color map entry (2 bytes each for RGB), do movea d5,a2 a2=closest_color add d5,d5 d5=2*closest_color  adda d5,a2 a2=3*closest_color adda a2,a2 a2=6*closest_color adda.l a0,a2 pointer to syscmap[closest_c] adda.l a1,a3 pointer to count[closest_c]  moveq #0,d5 zero upper byte moveq #0,d6 zero upper byte moveq #0,d7 zero upper byte move.w (a2),d5 get syscmap[cc].r move.w 2(a2),d6  get syscmap[cc].g move.w 4(a2),d7 get syscmap[cc].b add d5,ract(a6) ract=ract+syscmap[cc].r add d6,gact(a6) gact=gact+syscmap[cc].g add d7,bact(a6) bact=bact+syscmap[cc].b addq.b #1,(a3) increment count[cc] dbra d0,si40 loop (outer) movea.l a5,a2 a2 points to scratch array move.l gamut(gle_gcb),d0 d0= i:loop counter move d0,d3 save max pen for later moveq #0,d1 num of entries counter moveq #0,d5 zero upper byte moveq #0,d6 zero upper byte si120 move.b 0(a1,d0),d2 count[i] beq si130 if no count then goto next moveq #0,d5 zero upper byte move.b d0,(a2)+ store entry in scratch array move.b d2,(a2)+ B  store count in scratch array move d0,d4 i add d4,d4 2*(i) add d4,d4 4*(i) move.w 2(a0,d4),d5 syscmap[i].grn add d5,d5  2*grn add d5,d5 4*grn move.w 0(a0,d4),d6 syscmap[i].red add d6,d5 4*grn+red add d5,d5 8*grn+2*red add d6,d5  8*grn+3*red move.w 4(a0,d4),d6 syscmap[i].blu add d6,d5 8*grn+3*red+blu move d5,(a2)+ store brightness in scratch arry addq #1,d1 num of entries counter + 1 si130 dbra d0,si120 next i subq #1,d1 num of entries counter - 1 beq si160 only one entry then skip add d1,d1 add d1,d1  j moveq #0,d0 n=0 si140 move d0,d2 i=n si150 addq #4,d2 i=i+1 move 2(a5,d0),d3 brightness[n] cmp 2(a5,d2),d3 is brightness[i]>brightness[n] bge si155 then pull the old switcheroo move.l 0(a5,d2),d4 temp=record[i] move.l 0(a5,d0),0(a5,d2) record[i]=record[n] move.l d4,0(a5,d0) record[n]=temp si155 cmp d2,d1 is ij bgt si140 si160 moveq #0,d0 pixel=0 moveq #0,d3 i=0 moveq #0,d4 zero upper byte si170 moveq #0,d2 n=0 si180 move.b ditseq(d0),d4 move.b 0(a5,d3),dither_pattern(a6,d4) addq #1,d0 addq #1,d2 cmp.b 1(a5,d3),d2 is count[i]j bge si170 adda #768,a7 {SFB 4/12/85} return space to stack  bra rts ditseq dc.b 0,10,8,2,5,15,13,7,4,14,12,6,1,11,9,3 * here we repartition the dither pattern and place it into the trr pattern rgisters of * the CATSEYE. Later, in rpolygon, we will use trr to move the required scanline to * the screen using the "P" trr rule. We do this because there is not enough width * in offscreen frame buffer on the hrx machines to store a dithered scanline that * can span the 1280-pixel wide screen. SFB * * The dither pattern is a 4x4 array of byte-per-pixel pixels. * The data in it may be significant in from 1 to 8 planes. * The pattern registers are a 16x16 by up to 8 plane deep array of bit-per-pixel * data to combine into the frame buffer. We must replicate the 4x4 dither pattern * both vertically and horizontally to fill the 16x16 bit x n plane pattern register * set. * dither pattern (bytes): * (0,0) (0,1) (0,2) (0,3) * ... * (3,0) (3,1) (3,2) (3,3) * Pattern regs (bits): * plane 0 (0,0) (0,1)...(0,15) *  ... * (15,0) (15,1)...(15,15) * plane 1 (0,0) (0,1)...(0,15) * ... * (15,0) (15,1)...(15,15) * ... * plane n (0,0) (0,1)...(0,15) * ... * (15,0) (15,1)...(15,15) * Pascal entry point dither_to_pattregs(gcb); called from gator_fill_index_color * iff display is hrm CATSEYE. SFB gle_aras_out_dither_to_pattregs equ * Pascal entry point SFB movea.l 4(sp),gle_gcb movem.l a5/a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb movea.l deviceaddress(rgl_gcb),a0 lea pattregs(a0),a0 do this because can't use >127 displacement later move.l gamut(gle_gcb),d3 d3: how many planes to slice C moveq #0,d1 d1: pattern register index moveq #0,d2 d2: single bit selector next_plane equ * moveq #0,d6 d6: indexes columns of dither pattern (0..3) moveq #3,d4 d4: counts lines of dither pattern (3..0) next_line equ * moveq #3,d5 d5: counts columns of dither pattern (3..0) moveq #0,d0 d0: tmp, construct register data here next_bit equ * next byte of dither pattern cell->next bit of d0 btst d2,dither_pattern(rgl_gcb,d6) beq not_set bset d5,d0 not_set equ * addq #1,d6 next row of dither pattern dbra d5,next_bit mulu #$1111,d0 replicate 4 bits horizontally move.w d0,(a0,d1) move data to pattregs move.w d0,8(a0,d1) ditto, replicating vertically move.w d0,16(a0,d1) ditto, replicating vertically move.w d0,24(a0,d1) ditto, replicating vertically addq #2,d1  next register (in 4x4 space) dbra d4,next_line addq #1,d2 generate next plane mask add #24,d1 and step to next pattreg block of 16 words lsr #1,d3 check gamut: are we done yet (no 1 bits left)? bne next_plane bra rts page ************************************************************************** * * GET_P1P2 ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ) * * Returns lower left and upper right points * * INFO1 = XMIN *  INFO2 = XMAX * INFO3 = YMIN * INFO4 = YMAX * gle_aras_out_rget_p1p2 equ * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device gcb clr.l info1(gle_gcb) clr.l info3(gle_gcb) move.w hard_xmax(rgl_gcb),d0 ext.l d0 move.l d0,info2(gle_gcb) move.w hard_ymax(rgl_gcb),d0 ext.l d0 move.l d0,info4(gle_gcb) bra rts ****************************************************************************** * * AWAIT_BLANKING ( GCB : GRAPHICS_CONTROL_BLOCK_PTR ) * * loop until vertical blanking starts * gle_aras_out_rawait_blanking equ *  movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device gcb cmpi.w #3,devicetype(rgl_gcb) ck for 9836C bne.s blankgbox movea.l deviceaddress(rgl_gcb),a2 36c await_blanking blank1 equ * used to be move.b (a2),d0 btst #0,(a2) used to be btst #0,d0 beq.s blank1 bra.s noblank blankgbox cmpi.w #5,devicetype(rgl_gcb) ck for gatorbox bne.s noblank movea.l cmap_address(rgl_gcb),a2 gatbox await_blanking adda.l #2,a2 blank3 btst #0,(a2) bne.s blank3 noblank bra rts ****************************************************************************** * * SETGBOXCMAP( GCB : GRAPHICS_CONTROL_BLOCK_PTR ) * * set gatorbox color map entry INFO1 to values R,G,B (INFO2, INFO3, INFO4) * gle_aras_out_setgboxcmap equ * movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb  a6 = device gcb move.l info1(gle_gcb),d1 move.l info2(gle_gcb),d2 move.l info3(gle_gcb),d3 move.l info4(gle_gcb),d4 movea.l status(a5),a1 set up to check HSYNC in secondary moveq #1,d0 movea.l cmap_address(rgl_gcb),a0 cm00 btst #2,2(a0) wait for cmap not busy bne.s cm00 move.w d1,$b7(a0) set cmap pointer to correct entry * now update cmap color registers by waiting for video ( = not horizontal * retrace), then C wait for horizontal retrace, then immediately update * register. We wait for video first to ensure we don't catch * retrace in the middle or near the end. Colormap should be updated during * either horizontal or vertical retrace to ensure we don't get snow on * the screen during update. We use (a0)+ because it's the fastest to-mem * address mode available (the increment happens after cmap update), and we * have only a few microsec to update the registers. adda.l #$1b1,a0 point a0 at RED register cm10 btst d0,(a1) wait for video beq.s cm10 cm11 btst d0,(a1) wait for horizontal bne.s cm11 move.w d2,(a0)+ update red cm12 btst d0,(a1) beq.s cm12 cm13 btst d0,(a1) bne.s cm13 move.w d3,(a0)+ update green cm14 btst d0,(a1) beq.s cm14 cm15 btst d0,(a1) bne.s cm15 move.w d4,(a0)+ update blue bra rts ****************************************************************************** * * SET_NEREID( GCB : GRAPHICS_CONTROL_BLOCK_PTR ) * * set NEREID color map entry INFO1 to values R,G,B (INFO2, INFO3, INFO4) * gle_aras_out_set_nereid equ * movea.l 4(sp),gle_gcb  a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device gcb move.l info1(gle_gcb),d1 move.l info2(gle_gcb),d2 move.l info3(gle_gcb),d3 move.l info4(gle_gcb),d4 movea.l cmap_address(rgl_gcb),a0 nereid_cm00 equ * wait for cmap ready * NOP SFB 4/18/85 removed 10/03/86 SFB btst #2,2(a0) bne.s nereid_cm00 move 0,d0 delay for nereid SFB move.b d1,$b8(a0) set cmap index move 0,d0 delay for nereid SFB move.b d2,$b2(a0) set red move 0,d0 delay for nereid SFB move.b d3,$b4(a0) set green move 0,d0 delay for nereid SFB move.b d4,$b6(a0)  set blue move 0,d0 delay for nereid SFB move.b d0,$f0(a0) trigger color map load move 0,d0 delay for nereid SFB nereid_cm01 equ *  wait for load complete * NOP SFB 4/18/85 removed 10/03/86 SFB btst #2,2(a0) bne.s nereid_cm01 moveq #0,d1 set above 4 registers to 0 move 0,d0 delay for nereid SFB move.b d1,$b8(a0) set cmap index move 0,d0 delay for nereid SFB move.b d1,$b2(a0) set red move 0,d0  delay for nereid SFB move.b d1,$b4(a0) set green move 0,d0 delay for nereid SFB move.b d1,$b6(a0) set blue bra rts ****************************************************************************** * * SET_WOOD_CMAP( GCB : GRAPHICS_CONTROL_BLOCK_PTR ) * * set WOODCUT color map entry INFO1 to values R,G,B (INFO2, INFO3, INFO4) * gle_aras_out_set_wood_cmap equ * added WOODCUT support CFB 10JUN91 movea.l 4(sp),gle_gcb a4 = address of pointer to gcb move.l (sp)+,(sp) stack return address movem.l a5-a6,old_a5(gle_gcb) movea.l dev_dep_stuff(gle_gcb),rgl_gcb a6 = device gcb move.l info1(gle_gcb),d1 move.l info2(gle_gcb),d2 move.l info3(gle_gcb),d3 move.l info4(gle_gcb),d4 move.l #blueregimage,d5 move.l #dacimagewrite,d6 movea.l deviceaddress(rgl_gcb),a0 need control space address checkblue D  btst #0,2(a0,d5.l) check for color map busy bne.s checkblue loop until bit is clear move.b d1,0(a0,d6.l) write the index to the DAC move.b d2,4(a0,d6.l) then red to the DAC move.b d3,4(a0,d6.l) then green to the DAC move.b d4,3(a0,d5.l) then blue to BEECH bra rts gle_aras_out_gle_aras_out rts end * * Graphics Low End * * Module = STROKES * Programer = BJS * Date = 9/30/82 * * Purpose : To provide stroke tables * * Rev history * * Created - 9/30/82 * Modified - * * * (c) Copyright Hewlett-Packard Company, 1985. * All rights are reserved. Copying or other * reproduction of this program except for archival * purposes is prohibited without the prior * written consent of Hewlett-Packard Company. * * * RESTRICTED RIGHTS LEGEND * * Use, duplication, or disclosure by the Government * is subject to restrictions as set forth in * paragraph (b) (3) (B) of the Rights in Technical * Data and Computer Software clause in * DAR 7-104.9(a). * * HEWLETT-PACKARD COMPANY * Fort Collins, Colorado * * mname GLE_STROKE rorg 0 nosyms def GLE_GLE_STROKE_TABLE GLE_GLE_STROKE_TABLE equ * DC.L STD_CHAR-GLE_GLE_STROKE_TABLE DC.L STD_POINTER-GLE_GLE_STROKE_TABLE DC.L ROMAN_CHAR-GLE_GLE_STROKE_TABLE DC.L ROMAN_POINTER-GLE_GLE_STROKE_TABLE DC.L KATA_CHAR-GLE_GLE_STROKE_TABLE DC.L KATA_POINTER-GLE_GLE_STROKE_TABLE std_char EQU * DC.L $44C446CC DC.L $3ABC5CDA DC.L $34BC5CD4 DC.L $17F77999 DC.L $25D5E6E7 DC.L $D8B8A9AA DC.L $BBEB4CC4 DC.L $64F5E6D5 DC.L $E415FB2A DC.L $BBAC9BAA DC.L $749A9BAC DC.L $BCCBCA97 DC.L $95A4B4E7 DC.L $3ADC54B6 DC.L $BADC34D6 DC.L $DABC2BE5 DC.L $6BA518F8 DC.L $45CB18F8 DC.L $44B4B5C5 DC.L $C3B218F8 DC.L $44C5B5B4 DC.L $C415FB15 DC.L $FBF5E4A4 DC.L $959BACEC DC.L $FB3BCCC4 DC.L $34D41BAC DC.L $DCEBE9D8 DC.L $B89694E4 DC.L $1BACDCEB DC.L $E9D8B858 DC.L $E7E5D4A4 DC.L $9554DC98 DC.L $97E715A4 DC.L $D4E5E8D9 DC.L $999CEC18 DC.L $D8E7E5D4 DC.L $A4959BAC DC.L $DCEB1CEC DC.L $EAA6A428 DC.L $999BACDC DC.L $EBE9D8A8 DC.L $9795A4D4 DC.L $E5E7D815 DC.L $A4D4E5EB DC.L $DCAC9B99 DC.L $A8E848B8 DC.L $B9C9C844 DC.L $B4B5C5C4 DC.L $48B8B9C9 DC.L $C844B4B5 DC.L $C5C3B255 DC.L $A8DB17F7 DC.L $19F925D8 DC.L $AB1A9BAC DC.L $DCEBEAB7 DC.L $B634B457 DC.L $D9CAB9B8 DC.L $C7E7F8FA DC.L $DCBC9A96 DC.L $B4E4F514 DC.L $9BACECFB DC.L $F4789824 DC.L $AC1CECFB DC.L $F9E8A814 DC.L $E4F5F7E8 DC.L $7BECBC9A DC.L $96B4E4F5 DC.L $14E4F5FB DC.L $EC9C2CA4 DC.L $18C87C9C DC.L $94F4149C DC.L $FC18C87B DC.L $ECBC9A96 DC.L $B4F4F7D7 DC.L $149C18F8 DC.L $7CF42CEC DC.L $4CC424E4 DC.L $15A4C4D5 DC.L $DC3CFC14 DC.L $9C18B87C DC.L $B8F41C94 DC.L $F4149CC8 DC.L $FCF4149C DC.L $F4FC5CBC DC.L $9A96B4D4 DC.L $F6FADC14 DC.L $9CECFBF9 DC.L $E8985CBC DC.L $9A96B4D4 DC.L $F6FADC56 DC.L $F4149CEC DC.L $FBF9E898 DC.L $38F415A4 DC.L $E4F5F7E8 DC.L $A8999BAC DC.L $ECFB1CFC DC.L $4CC41C95 DC.L $A4E4F5FC DC.L $1C9BC4FB DC.L $FC1C94C9 DC.L $F4FC14FC DC.L $1CF41CC8 DC.L $FC48C41C DC.L $FC94F46C DC.L $BCB4E41B DC.L $F52CDCD4 DC.L $A417CAF7 DC.L $00F03CDA DC.L $29D9E8E4 DC.L $67B7A6A5 DC.L $B4F41C94 DC.L $17B9D9E8 DC.L $E5D4B496 DC.L $68D9A998 DC.L $95A4D4E5 DC.L $6CE467C9 DC.L $A99895A4 DC.L $C4E617E7 DC.L $E8D9A998 DC.L $95A4D4E5 DC.L $6BDCCCBB DC.L $B418D867 DC.L $C9A99895 DC.L $A4C4E669 DC.L $E2D1A192 DC.L $1C9417B9 DC.L $D9E8E439 DC.L $C9C44BCB DC.L $59E9E2D1 DC.L $A1926BEB DC.L $1C945995 DC.L $37E43CCC DC.L $C4199418 DC.L $A9B9C8C4 DC.L $48D9E9F8 DC.L $F4149917 DC.L $B9D9E8E4 DC.L $1895A4D4 DC.L $E5E8D9A9 DC.L $98119917 DC.L $B9D9E8E5 DC.L $D4B49667 DC.L $D9A99895 DC.L $A4C4E669 DC.L $E129A427 DC.L $C9D9E868 DC.L $D9A998E5 DC.L $D4A4953B DC.L $B5C4D4E5 DC.L $19D91995 D DC.L $A4C4E669 DC.L $E419C4F9 DC.L $1995A4B4 DC.L $C5C845D4 DC.L $E4F5F919 DC.L $E4699419 DC.L $C479A191 DC.L $19E994E4 DC.L $6CDCCBC9 DC.L $B8C7C5D4 DC.L $E44FC02C DC.L $BCCBC9D8 DC.L $C7C5B4A4 DC.L $18A9B9D7 DC.L $E7F81BAC DC.L $4C9917EC DC.L $7B9524F9 DC.L $77C464F5 std_pointer EQU * DC.W 1 DC.W 1 DC.W 5 DC.W 9 DC.W 17 DC.W 29 DC.W 41 DC.W 53 DC.W 55 DC.W 59 DC.W 63 DC.W 69 DC.W 73 DC.W 79 DC.W 81 DC.W 86 DC.W 88 DC.W 98 DC.W 103 DC.W 113 DC.W 126 DC.W 131 DC.W 140 DC.W 151 DC.W 156 DC.W 172 DC.W 183 DC.W 193 DC.W 204 DC.W 207 DC.W 211 DC.W 214 DC.W 224 DC.W 240 DC.W 248 DC.W 261 DC.W 269 DC.W 277 DC.W 283 DC.W 288 DC.W 297 DC.W 303 DC.W 309 DC.W 316 DC.W 323 DC.W 326 DC.W 331 DC.W 335 DC.W 344 DC.W 351 DC.W 362 DC.W 371 DC.W 383 DC.W 387 DC.W 393 DC.W 398 DC.W 403 DC.W 407 DC.W 412 DC.W 416 DC.W 420 DC.W 422 DC.W 426 DC.W 429 DC.W 431 DC.W 433 DC.W 443 DC.W 453 DC.W 461 DC.W 471 DC.W 481 DC.W 488 DC.W 501 DC.W 508 DC.W 513 DC.W 521 DC.W 527 DC.W 530 DC.W 542 DC.W 549 DC.W 558 DC.W 568 DC.W 578 DC.W 584 DC.W 592 DC.W 599 DC.W 606 DC.W 609 DC.W 620 DC.W 624 DC.W 629 DC.W 633 DC.W 642 DC.W 644 DC.W 653 DC.W 659 DC.W 673 roman_char equ * DC.L $3BDD2DCB DC.L $2BCDEB2B DC.L $AB5BDB1D DC.L $AEBEDCEC DC.L $FD6AEBDC DC.L $BCABA414 DC.L $F416B618 DC.L $B81EFE3C DC.L $AC9B9AA9 DC.L $B9CACBBC DC.L $68D9A998 DC.L $95A4D4E5 DC.L $44C3D2C1 DC.L $B1149BF4 DC.L $FB1DAEBE DC.L $DCECFD14 DC.L $9917B9D9 DC.L $E8E41CAD DC.L $BDCCDCED DC.L $44CA4CCC DC.L $76F5E4B4 DC.L $A5A6D9DA DC.L $5CDC5ABA DC.L $A9A7B6D6 DC.L $E7E9DAFC DC.L $3A9C3694 DC.L $56F46AEB DC.L $DCBCABA4 DC.L $14F417B7 DC.L $6BDCBCAB DC.L $D8C749B8 DC.L $E5D4B4A5 DC.L $29D9E8E4 DC.L $67B7A6A5 DC.L $B4F42BCD DC.L $EB17E7E8 DC.L $D9A99895 DC.L $A4D4E52B DC.L $CDEB59A9 DC.L $9895A4D4 DC.L $E5E8D92B DC.L $CDEB1995 DC.L $A4C4E669 DC.L $E42BCDEB DC.L $29D9E8E4 DC.L $67B7A6A5 DC.L $B4F43BDD DC.L $17E7E8D9 DC.L $A99895A4 DC.L $D4E53BDD DC.L $59A99895 DC.L $A4D4E5E8 DC.L $D93BDD19 DC.L $95A4C4E6 DC.L $69E43BDD DC.L $29D9E8E4 DC.L $67B7A6A5 DC.L $B4F43DDB DC.L $17E7E8D9 DC.L $A99895A4 DC.L $D4E52DCB DC.L $59A99895 DC.L $A4D4E5E8 DC.L $D92DCB19 DC.L $95A4C4E6 DC.L $69E42DCB DC.L $29D9E8E4 DC.L $67B7A6A5 DC.L $B4F42BAB DC.L $5BDB17E7 DC.L $E8D9A998 DC.L $95A4D4E5 DC.L $2BAB5BDB DC.L $59A99895 DC.L $A4D4E5E8 DC.L $D92BAB5B DC.L $DB1995A4 DC.L $C4E669E4 DC.L $2BAB5BDB DC.L $149BACEC DC.L $FBF47898 DC.L $4DBECFDE DC.L $CD39C9C4 DC.L $2BCDEB3C DC.L $DCFAF6D4 DC.L $B4969ABC DC.L $7C94149B DC.L $ACFC4CC4 DC.L $F417C748 DC.L $E829D9E8 DC.L $E467B7A6 DC.L $A5B4F44A DC.L $BBCCDBCA DC.L $39C9C44B DC.L $ED59A998 DC.L $95A4D4E5 DC.L $E8D96994 DC.L $19B9C8C5 DC.L $B4A49596 DC.L $A7F7F8E9 DC.L $D9C845D4 DC.L $E4F5149B DC.L $ACECFBF4 DC.L $78982EAE DC.L $6EEE39C9 DC.L $C42DCB3C DC.L $DCFAF6D4 DC.L $B4969ABC DC.L $2EAE6EEE DC.L $1C95A4E4 DC.L $F5FC2EAE DC.L $6EEE7C9C DC.L $94F418C8 DC.L $4DDE39C9 DC.L $C42BAB5B DC.L $DB149BAC DC.L $CCDBDAB8 DC.L $D8E7E5D4 DC.L $B4000000 roman_pointer equ * DC.W 1 DC.W 3 DC.W 5 DC.W 8 DC.W 12 DC.W 18 DC.W 18 DC.W 18 DC.W 30 DC.W 32 DC.W 32 DC.W 32 DC.W 41 DC.W 41 DC.W 54 DC.W 64 DC.W 77 DC.W 81 DC.W 91 DC.W 107 DC.W 117 DC.W 117 DC.W 129 DC.W 129 DC.W 129 DC.W 142 DC.W 155 DC.W 167 DC.W 177 DC.W 189 DC.W 201 DC.W 212 DC.W 221 DC.W 233 DC.W 245 DC.W 256 DC.W 265 DC.W 279 DC.W 293 DC.W 306 DC.W 317 DC.W 330 DC.W 336 DC.W 347 DC.W 358 DC.W 373 DC.W 378 DC.W 389 DC.W 407 DC.W 419 DC.W 424 DC.W 437 DC.W 447 DC.W 455 DC.W 462 DC.W 474 kata_char equ * DC.L $279695A4 DC.L $B4C5C6B7 DC.L $A76CBCB8 DC.L $24D4D826 DC.L $C447C8B8 DC.L $B7C71BFB DC.L $F7C4B418 DC.L $F829E9E8 DC.L $C647C5B4 DC.L $59A648C4 DC.L $27A8E8E6 DC.L $C448C938 DC.L $D848C424 DC.L $E428E859 DC.L $D457A428 DC.L $E8E7D639 DC.L $B438D8D4 DC.L $24F428E8 DC.L $E4A436E6 DC.L $28A748C7 DC.L $68E6C418 DC.LE  $F81BFBF9 DC.L $C749C5B4 DC.L $6C974AC4 DC.L $189AFAF7 DC.L $C44C4CCA DC.L $2BEB4BC5 DC.L $15F55CD4 DC.L $1AFA5995 DC.L $1AFAF5E4 DC.L $3CB6944C DC.L $C46AAA17 DC.L $F719BBFB DC.L $F8B42CAA DC.L $992AFA5A DC.L $D5B41BFB DC.L $F5952CA8 DC.L $1AFA6CE7 DC.L $B41BBB18 DC.L $B814C4F7 DC.L $F91BFBFA DC.L $9447F41A DC.L $FAF9D72C DC.L $A5B4F474 DC.L $1BB97BF8 DC.L $B418BABB DC.L $FBF8B438 DC.L $D62BDBEC DC.L $4BC6A418 DC.L $F81B9949 DC.L $CB7BF7C4 DC.L $2BEB7999 DC.L $49C6A43C DC.L $B43AE74C DC.L $C6A41AFA DC.L $2BEB15F5 DC.L $1BFBFAFA DC.L $9438E51B DC.L $FB9544C8 DC.L $F54CCB6C DC.L $E8A414A5 DC.L $AA5BF9F4 DC.L $1C95A4F4 DC.L $19E91BFB DC.L $F8B4A419 DC.L $BBF7F64C DC.L $C41AFA27 DC.L $A69567F6 DC.L $F51BFBF9 DC.L $C637E42C DC.L $BBDBEA29 DC.L $B8D8E726 DC.L $B5D5E45B DC.L $9795F576 DC.L $76F47BFA DC.L $9429E51B DC.L $FB18F83B DC.L $B5C4F43C DC.L $B41AFAF9 DC.L $F9D72BDB DC.L $D515F51B DC.L $FBF59528 DC.L $F82BEB19 DC.L $F9F7C4C4 DC.L $2BA76BE6 DC.L $C42BA594 DC.L $4BC4D4F6 DC.L $F72BA4C4 DC.L $F775959B DC.L $FBF5199B DC.L $FBF7C4B4 DC.L $1ABA7AF9 DC.L $B494399B DC.L $3CDA2C9B DC.L $9AA9B9CA DC.L $CBBCAC1C DC.L $C9FC49C4 DC.L $68A826E6 kata_pointer EQU * DC.W 1 DC.W 10 DC.W 13 DC.W 16 DC.W 18 DC.W 23 DC.W 30 DC.W 37 DC.W 41 DC.W 48 DC.W 54 DC.W 60 DC.W 66 DC.W 71 DC.W 77 DC.W 84 DC.W 86 DC.W 93 DC.W 97 DC.W 105 DC.W 111 DC.W 117 DC.W 124 DC.W 130 DC.W 135 DC.W 143 DC.W 147 DC.W 154 DC.W 162 DC.W 168 DC.W 177 DC.W 182 DC.W 190 DC.W 198 DC.W 205 DC.W 212 DC.W 216 DC.W 221 DC.W 225 DC.W 232 DC.W 240 DC.W 243 DC.W 249 DC.W 255 DC.W 260 DC.W 264 DC.W 274 DC.W 280 DC.W 292 DC.W 299 DC.W 304 DC.W 312 DC.W 319 DC.W 324 DC.W 330 DC.W 337 DC.W 342 DC.W 350 DC.W 354 DC.W 359 DC.W 365 DC.W 371 DC.W 375 DC.W 384 DC.W 393 $TABLES$ $LIST OFF$ { } { Pascal work station graphics library } { } { Module = DGL_TYPES } { Programer = BJS } { Date = 2/1/82 } { Purpose: Holds declarations which must be imported by graphics library users when interfacing with some library routines. } { Rev history } { 6-15-82 BJS Added data type gchar_list  } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in  DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $TABLES$ $LIST OFF$ $modcal$ $include 'OPTIONS'$ $linenum 1000$ module DGL_TYPES; export type gbyte = -128 .. 127; gshortint = -32768 .. 32767; gstring255 = string[255]; gshortint_list = array [1..maxint] of gshortint; gint_list = array [1..maxint] of integer; greal_list = array [1..maxint] of real; gchar_list = packed array [1..maxint] of char; implement end. { DGL_TYPES } $LIST ON$ E wc*COMPILER. q ************************************************ * * * GRAPHICS LIBRARY -- DGL * * * ************************************************ eOPTIONS f/$FLOAT_HDW/d ˙h˙ci OFF$ ˙cqse aSTROKES n cGLE_TYPES n cGLE_UTLS n aGLE_AUTL n aASM_STEXT n aASM_SCLIP n cGLE_GEN n cGLE_GENI n cGLE_STEXT n cGLE_SMARK n cGLE_SCLIP n cGLE_HPGL n cGLE_HPGLI n cGLE_HILI n cGLE_KNOB n aRGL n  cGLE_RGL n cGLE_FILE n cGLE_HPIB n cG_HILREL n lh77 oGLE_LIB. iGLE_AUTL aiGLE_UTLS aiGLE_TYPES aiSTROKES aiGLE_STEXT aiASM_STEXT aiGLE_SMARK aiGLE_SCLIP aiASM_SCLIP aiGLE_FILE aiGLE_HPIB aiGLE_HPGL aiGLE_HPGLI aiGLE_HILI aiG_HILREL aiGLE_RGL aiRGL aiGLE_KNOB aiGLE_GEN aiGLE_GENI akq fr=.CODE cGLE_LIB,GLE_LIB.CODE q aDGL_AUTL n cTYPES n cDGL_VARS n aDGL_IBODY n cDGL_TOOLS n cGEN n cDGL_RAS n cDGL_HPGL n cDGL_C_OUT n cDGL_KNOB n cDGL_HPGLI n cDGL_HILI n cD_HILREL n cDGL_C_IN n cLIB n cDGL_POLY n cDGL_INQ n lh50 oGRAPHICS. iGLE_LIB aiTYPES aiDGL_VARS aiDGL_IBODY aiDGL_AUTL aiDGL_TOOLS aiGEN aiDGL_RAS aiDGL_HPGL aiDGL_C_OUT aiDGL_KNOB aiDGL_HPGLI aiDGL_HILI aiD_HILREL aiDGL_C_IN aiLIB aiDGL_POLY aiDGL_INQ akq ************************************************ * * * GRAPHICS LIBRARY -- DGL (HARDWARE FLT PT) * * * ************************************************ eOPTIONS f/$FLOAT_HDW/d ˙h˙ci TEST$ ˙cqse fr=.CODE q aSTROKES n cGLE_TYPES n cGLE_UTLS n aGLE_AUTL n aASM_STEXT n aASM_SCLIP n cGLE_GEN n cGLE_GENI n cGLE_STEXT n cGLE_SMARK n cGLE_SCLIP n cGLE_HPGL n cGLE_HPGLI n cGLE_HILI n cGLE_KNOB n aRGL n cGLE_RGL n cGLE_FILE n cGLE_HPIB n cG_HILREL n lh77 oGLE_LIB. iGLE_AUTL aiGLE_UTLS aiGLE_TYPES aiSTROKES aiGLE_STEXT aiASM_STEXT aiGLE_SMARK aiGLE_SCLIP aiASM_SCLIP aiGLE_FILE aiGLE_HPIB aiGLE_HPGL aiGLE_HPGLI aiGLE_HILI aiG_HILREL aiGLE_RGL aiRGL aiGLE_KNOB aiGLE_GEN aiGLE_GENI akq fr=.CODE cGLE_LIB,GLE_LIB.CODE q aDGL_AUTL n cTYPES n cDGL_VARS n aDGL_IBODY n cDGL_TOOLS n cGEN n cDGL_RAS n cDGL_HPGL n cDGL_C_OUT n cDGL_KNOB n cDGL_HPGLI n cDGL_HILI n cD_HILREL n cDGL_C_IN n cLIB n cDGL_POLY n cDGL_INQ n lh50 oFGRAPHICS. iGLE_LIB aiTYPES aiDGL_VARS aiDGL_IBODY aiDGL_AUTL aiDGL_TOOLS aiGEN aiDGL_RAS aiDGL_HPGL aiDGL_C_OUT aiDGL_KNOB aiDGL_HPGLI aiDGL_HILI aiD_HILREL aiDGL_C_IN aiLIB aiDGL_POLY aiDGL_INQ akq eOPTIONS f/$FLOAT_HDW/d ˙h˙ci OFF$ ˙cqse fr=.CODE q ************************************************ * * * GRAPHICS LIBRARY -- DGL (60820 VERSION) * * * ************************************************ eOPTIONS f/$FLOAT_HDW/d ˙h˙ci ON$ ˙cqse wc*COMP20. q fr=.CODE q aSTROKES n cGLE_TYPES n cGLE_UTLS n aGLE_AUTL n aASM_STEXT n aASM_SCLIP n cGLE_GEN n cGLE_GENI n cGLE_STEXT n cGLE_SMARK n cGLE_SCLIP n cGLE_HPGL n cGLE_HPGLI n cGLE_HILI n cGLE_KNOB n aRGL n cGLE_RGL n cGLE_FILE n cGLE_HPIB n cG_HILREL n lh77 oGLE_LIB. iGLE_AUTL aiGLE_UTLS aiGLE_TYPES aiSTROKES aiGLE_STEXT aiASM_STEXT aiGLE_SMARK aiGLE_SCLIP aiASM_SCLIP aiGLE_FILE aiGLE_HPIB aiGLE_HPGL aiGLE_HPGLI aiGLE_HILI aiG_HILREL aiGLE_RGL aiRGL aiGLE_KNOB aiGLE_GEN aiGLE_GENI akq fr=.CODE cGLE_LIB,GLE_LIB.CODE q aDGL_AUTL n cTYPES n cDGL_VARS n aDGL_IBODY n cDGL_TOOLS n cGEN n cDGL_RAS n cDGL_HPGL n cDGL_C_OUT n cDGL_KNOB n cDGL_HPGLI n cDGL_HILI n cD_HILREL n cDGL_C_IN n cLIB n cDGL_POLY n cDGL_INQ n lh50 oFGRAPH20. iGLE_LIB aiTYPES aiDGL_VARS aiDGL_IBODY aiDGL_AUTL aiDGL_TOOLS aiGEN aiDGL_RAS aiDGL_HPGL aiDGL_C_OUT aiDGL_KNOB aiDGL_HPGLI aiDGL_HILI aiD_HILREL aiDGL_C_IN aiLIB aiDGL_POLY aiDGL_INQ akq eOPTIONS f/$FLOAT_HDW/d ˙h˙ci OFF$ ˙cqse fr=.CODE q wc*COMPILER. q ***************************************************************************** F AWAIT_BLANKING equ 24 BACKGROUND equ 398 BUFFER_MODE equ 32 CALC_SOFT_TEXT_XFORM equ 668 CALC_TEXT_XFORM equ 666 CHAR_HEIGHT equ 466 CHAR_JUST_X equ 486 CHAR_JUST_Y equ 490 CHAR_SIZE equ 40 CHAR_SIZES equ 432 CHAR_SPACE equ 470 CHAR_WIDTH equ 462 CLEAR equ 48 CLIP_LIMITS equ 56 CLIP_LIMITS_XMAX equ 498 CLIP_LIMITS_XMIN equ 494 CLIP_LIMITS_YMAX equ 506 CLIP_LIMITS_YMIN equ 502 COLOR_MAP_SUPPORT equ 406 COMPLEMENT_SUPPORT equ 400 CONT_LINESTYLES equ 426 COSX_TABLE equ 570 COSY_TABLE equ 586 CURRENT_BUFFER_MODE equ 520 CURRENT_COLOR_INDEX equ 530 CURRENT_CURSOR_STATE equ 510 CURRENT_CURSOR_X equ 512 CURRENT_CURSOR_Y equ 516 CURRENT_DRAWING_MODE equ 534 CURRENT_FILL_INDEX equ 532 CURRENT_LINESTYLE equ 522 CURRENT_LINESTYLE_MODE equ 528 CURRENT_LINESTYLE_PATTERN equ 524 CURRENT_LINEWIDTH equ 536 CURRENT_PATTERN_LENGTH equ 526 CURRENT_POLYGON_BLUE equ 544 CURRENT_POLYGON_COLOR equ 538 CURRENT_POLYGON_GREEN equ 542 CURRENT_POLYGON_RED equ 540 CURRENT_POS_X equ 434 CURRENT_POS_Y equ 438 CURSOR equ 64 DEFINE_COLOR_MAP equ 72 DEFINE_DRAWING_MODE equ 80 DEVICE_BUF equ 332 DEVICE_INFO equ 340 DEVICE_INFO_CHAR_COUNT equ 344 DEV_DEP_STUFF equ 336 DISPLAY_HANDLER_CHAR_COUNT equ 364 DISPLAY_HANDLER_NAME equ 358 DISPLAY_MAX_X equ 390 DISPLAY_MAX_Y equ 394 DISPLAY_MIN_X equ 382 DISPLAY_MIN_Y equ 386 DISPLAY_NAME equ 350 DISPLAY_NAME_CHAR_COUNT equ 356 DISPLAY_RES_X equ 366 DISPLAY_RES_Y equ 374 DITHER_SUPPORT equ 416 DRAW equ 88 DUMMY_XXX equ 280 END_X equ 442 END_Y equ 446 ERASE_SUPPORT equ 404 ERROR_RETURN equ 346 FILL_INDEX_COLOR equ 96 FLUSH_BUFFER equ 104 GAMUT equ 422 GET_COLOR_MAP equ 112 GET_POLYGON_INFO equ 128 GET_RASTER equ 120 GLOAD equ 136 GRAPHICS_ON_OFF equ 144 GSTORE equ 152 INDEX_COLOR equ 160 INFO1 equ 0 INFO2 equ 4 INFO3 equ 8 INFO4 equ 12 INFO_PTR1 equ 16 INFO_PTR2 equ 20 INQ_P1P2 equ 168 IOCB equ 328 IO_INQ_TIMEOUT equ 288 IO_READ equ 296 IO_SET_TIMEOUT equ 304 IO_TERM equ 312 IO_WRITE equ 320 KATA equ 460 LINESTYLE equ 184 LINEWIDTH equ 176 LINEWIDTHS equ 430 LINE_SPACE equ 474 MARKER equ 192 MARKER_HEIGHT equ 456 MARKER_SIZE equ 200 MARKER_TYPE equ 450 MARKER_WIDTH equ 452 MOVE equ 208 NON_DOMINANT_SUPPORT equ 402 OLD_A5 equ 546 OLD_A6 equ 550 OUTPUT_ESCAPEI equ 216 OUTPUT_ESCAPEO equ 224 PALLETTE equ 418 POLYGON equ 232 POLYGON_FILL_FACTOR equ 412 POLYGON_SOLID_FILL equ 414 POLYGON_SUPPORT equ 408 REDEF_BACKGROUND equ 410 SET_MARKER equ 240 SINX_TABLE equ 618 SINY_TABLE equ 634 SOFT_CLIP_CPX equ 722 SOFT_CLIP_CPY equ 726 SOFT_CLIP_SAVEX0 equ 704 SOFT_CLIP_SAVEX1 equ 708 SOFT_CLIP_SAVEY0 equ 712 SOFT_CLIP_SAVEY1 equ 716 SOFT_CLIP_SWITCH equ 720 SOFT_FONT_PTR equ 676 SOFT_TEXT_TEMP1 equ 680 SOFT_TEXT_TEMP2 equ 684 SPOOLING equ 348 TEXT equ 248 TEXT_COS_DIR equ 482 TEXT_DIR equ 256 TEXT_JUST equ 264 TEXT_LINE_X equ 562 TEXT_LINE_Y equ 566 TEXT_SIN_DIR equ 478 TEXT_SPACE_X equ 554 TEXT_SPACE_Y equ 558 TEXT_SPACING equ 272 UNCLIPPED_DRAW equ 696 UNCLIPPED_MOVE equ 688 VECT_LINESTYLES equ 428 { } { DGL device dependent init routine } { } { Module = DGL_KNOB } { Programer = BJS } { Date = 2 -10-83 } {  } { Purpose: To provide device dependent initialization for the knob. } { Rev history } { Created - 2 -10-82 BJS  } { Modified - 07-23-85 BJS Fixed range error on using knob with echos larger then 1. } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduF ction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS', 'GEN', 'DGL_C_OUT', 'DGL_TOOLS'$ {SFB 6/25/85} $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 18000$ module DGL_KNOB; export procedure dgl_knob_init; implement import dgl_types, dgl_vars, gle_types, gle_gen, gle_geni, gle_ras_out, {SFB 7/8/85} dgl_gen, dgl_confg_out {SFB 6/25/85}; var last_knob_rx, last_knob_ry : real; last_knob_dx, last_knob_dy : integer; procedure knob_sample_locator( echo : integer; var rx,ry : real ); { Purpose : To sample the locator device } begin rx := last_knob_rx; ry := last_knob_ry; gle_gcbi^.info1 := echo; gle_input_echo (gle_gcbi); { echo on locator device } end; { sample_locator } procedure knob_await_locator( var echo : integer; var button : integer; var rx,ry : real ); { Purpose : To activate the locator, and wait for operator termination } var echoerror : boolean; dx,dy : integer; last_x,last_y : integer; echo_gcb : graphics_control_block_ptr; save_n_glines : integer; {SFB 7/8/85} begin if (echo < 0) or (echo > 8) then echo := 1; { ck echo range }  { ck for display echo, and display not enabled } if (not disp_init) and (echo >1) then begin echoerror := true; echo := 1; end else echoerror := false; with gcb^,gle_gcbi^ do begin current_echo_type := echo;  { Init save area. This area is used only for echo type 1, however a value of zero means that it should NOT be restored at the end of echoing } save_n_glines := 0; {SFB 7/8/85}{Moved outside of echo type condition checking. BJS 7/23/85} if echo < 2 then begin input_cpx := last_knob_dx; input_cpy := last_knob_dy; echo_gcb := gle_knob_echo_gcb; if echo = 1 then begin with gle_knob_echo_gcb^ do begin info1 := 0; {disable expand SFB 6/25/85} info2 := 1; { do not init DGL stuff } device_info := ADDR('3 '); device_info_char_count := 1; if disp_init then {SFB 7/8/85} if gle_gcb^.display_handler_name = 'RASTER' then with raster_device_rec_ptr(gle_gcb^.dev_dep_stuff)^ do save_n_glines := n_glines; configure_gle ( gle_knob_echo_gcb ); if error_return <> 0 then error (err_no_display_hardware); { define echo edges } input_min_x := 0; input_max_x := display_max_x; input_min_y := 0; input_max_y := display_max_y; end; end; info2 := 1; end else begin echo_gcb := gle_gcb; with cur_disp_lim do begin input_min_x := trunc(xmin+0.5); input_max_x := trunc(xmax+0.5); input_min_y := trunc(ymin+0.5); input_max_y := trunc(ymax+0.5); input_cpx := d_loc_echo_x; input_cpy := d_loc_echo_y; info2 := display_echo_mult; end; end; gle_start_digitize (gle_gcbi); last_x := -32768; last_y := -32768; repeat gle_sample ( gle_gcbi ); button := gle_gcbi^.info3; dx := info1; dy := info2; if (dx <> last_x) or (dy <> last_y) then begin last_x := dx; last_y := dy; if (echo > 0) then with echo_gcb^ do begin info1 := dx; info2 := dy; info3 := 1; gle_cursor ( echo_gcb ); end; end; until button = -1; gle_get_digitize(gle_gcbi); button := info3; if save_n_glines > 0 then {SFB 7/8G /85} with gle_gcb^, raster_device_rec_ptr(dev_dep_stuff)^ do n_glines := save_n_glines; if echo > 1 then begin dx := info1; dy := info2; end else begin last_knob_dx := dx; { save before convert } last_knob_dy := dy; convert_ltod(info1,info2,dx,dy); end; convert_dtow(dx,dy,rx,ry); adjust_return_echo ( rx, ry ); last_knob_rx := rx; last_knob_ry := ry; if echo > 0 then with echo_gcb^ do begin info3 := 0; gle_cursor(echo_gcb); { remove cursor from screen } end; if echo = 1 then begin info1 := echo; gle_input_echo ( gle_gcbi ); end; end; if echoerror then error (err_echo_dis_int); end; { await_locator } procedure dgl_knob_init;  begin with gcb^ do begin proc_await_locator := knob_await_locator; proc_sample_locator := knob_sample_locator; last_knob_rx := 0; last_knob_ry := 0; last_knob_dx := 0; last_knob_dy := 0; end; end; end. { dgl_knob } { } { DGL device dependent init routine } { } { Module = DGL_HPHIL_RELI } { Programer = SFB } { Date = 9 -09-85 } {  } { Purpose: To provide device dependent initialization for HPHIL relative } { locator devices } { Rev history  } { Created - 3 -25-85 SFB } { Hacked from DGL_HILI (DGL_ABS) 9/9/85 SFB } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government  is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $search 'GLE_LIB', 'TYPES', 'DGL_VARS', 'GEN', 'DGL_C_OUT'$ $modcal$ $include 'OPTIONS'$ { ******************** COMPILER OPTIONS ****************** } $linenum 18000$ module DGL_HPHIL_RELI; export procedure dgl_hphili_rel_init; implement import dgl_types, dgl_vars, gle_types, gle_gen, gle_geni, dgl_gen; procedure hphil_rel_sample_locator( echo : integer; var rx,ry : real ); { Purpose : To sample the locator device  } var dx, dy : integer; begin with gle_gcbi^ do begin gle_sample(gle_gcbi); convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); info1 := echo; gle_input_echo (gle_gcbi); { echo on locator device }  end; end; { sample_locator } procedure hphil_rel_await_locator(var echo : integer; var button : integer; var rx,ry : real ); { Purpose : To activate the locator, and wait for operator termination } var echoerror : boolean;  dx,dy : integer; last_x,last_y : integer; begin if (echo < 0) or (echo > 8) then echo := 1; { ck echo range } { ck for display echo, and display not enabled } if (not disp_init) and (echo >1) then begin echoerror := true; echo G := 1; end else echoerror := false; with gcb^,gle_gcbi^ do begin current_echo_type := echo; info2 := 0; gle_start_digitize (gle_gcbi); last_x := {d_loc_echo_x}-32768; {SFB} last_y := {d_loc_echo_y}-32768; {SFB} if echo > 1 then with gle_gcb^ do begin info1 := d_loc_echo_x; info2 := d_loc_echo_y; info3 := 1; { on } gle_cursor ( gle_gcb ); { perform first echo at lep } end; repeat gle_sample ( gle_gcbi ); convert_ltod(info1,info2,dx,dy); button := info3; if (dx <> last_x) or (dy <> last_y) then begin last_x := dx; last_y := dy; if (echo > 1) and (not disp_eq_loc) then with gle_gcb^ do begin info1 := dx; info2 := dy; info3 := 1; gle_cursor ( gle_gcb ); end; end; until button = -1; gle_get_digitize(gle_gcbi); button := info3; convert_ltod(info1,info2,dx,dy); convert_dtow(dx,dy,rx,ry); adjust_return_echo ( rx, ry ); if echo > 1 then with gle_gcb^ do begin info3 := 0; gle_cursor(gle_gcb); { remove cursor from screen } end; if echo = 1 then begin info1 := echo; gle_input_echo ( gle_gcbi ); end; end; if echoerror then error (err_echo_dis_int); end; { await_locator } procedure dgl_hphili_rel_init; begin with gcb^ do begin proc_await_locator := hphil_rel_await_locator; proc_sample_locator := hphil_rel_sample_locator; end; end; end. { dgl_hphili_rel_init } { } { Graphics Low End } { } { Module = GLE_HPGL_IN } { Programer = BJS } { Date = 10-10-82 } {  } { Purpose: To provide HPGL input handler routines. } { Rev history } { Created - 10-10-82  } { Modified - 03-15-84 BDS Added support for 7586B, 7550A, 7440, 7090 } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $SEARCH 'GLE_TYPES','GLE_UTLS','GEN_TOOLS'$ $modcal$ $INCLUDE 'OPTIONS'$ { ******************* COMPILER OPTIONS ******************* } $LINENUM 18000$ $ALLOW_PACKED ON$ {JWS 3/31/87} module gle_hpgl_in; import gle_types; export const max_buffer = 255; buffer_fudge = 32; type ascii_buffer_ptr = ^ascii_buffer; ascii_buffer = packed record maximum : integer; current : integer; data : packed array [1..max_buffer] of char; end; procedure gle_init_hpgl_input ( gcbi : graphics_input_control_block_ptr); implement import gle_utls{, gen_tools}; procedure hpgl_flush_buffer ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^, ascii_buffer_ptr(device_buf)^ do begin if current <> 0 then call (io_write,iocb,device_buf); end; end; procedure add_char_data ( gcbi : graphics_input_control_block_ptr; count : gle_shortint; s : anychar_ptr ); var i : gle_shortint; begin with gcbi^,ascii_buffer_ptr(gcbi^.device_buf)^ do begin for i := 1 to count do data[i+current] := s^[i]; current := currH ent + count; end; end; procedure add_parm_data ( gcbi : graphics_input_control_block_ptr; value : gle_shortint); var count : gle_shortint; begin with gcbi^,ascii_buffer_ptr(gcbi^.device_buf)^ do begin gle_write_integer (value,count,addr(data[current+1])); current := current + count; end; end; procedure hpgl_input_escapeo ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do begin add_char_data(gcbi,info1,anyptr(info_ptr1)); hpgl_flush_buffer ( gcbi ); end; end; procedure hpgl_input_escapei ( gcbi : graphics_input_control_block_ptr ); var i : gle_shortint; sptr : anychar_ptr; begin with gcbi^,ascii_buffer_ptr(gcbi^.device_buf)^ do begin call (io_read, iocb, device_buf);  sptr := anyptr(info_ptr1); info1 := current; for i := 1 to current do sptr^[i] := data[i]; current := 0; { reset buffer counter } end; end; procedure hpgl_get_input_p1p2 ( gcbi : graphics_input_control_block_ptr ); var cnt : gle_shortint; tcnt : gle_shortint; temp : integer; begin with gcbi^, ascii_buffer_ptr(gcbi^.device_buf)^ do begin add_char_data ( gcbi, 2, addr('OP') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); tcnt := 1; info1 := gle_read_integer (current,addr(data[1]),cnt); cnt := cnt + tcnt; info3 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info2 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info4 := gle_read_integer (current,addr(data[cnt]),tcnt); current := 0; if info1 > info2 then { make xmin <= xmax } begin temp := info1; info1 := info2; info2 := temp; end; if info3 > info4 then { make ymin <= ymax } begin temp := info3; info3 := info4; info4 := temp; end; end; end; procedure hpgl_get_input_hard_clip ( gcbi : graphics_input_control_block_ptr ); var tcnt,cnt : gle_shortint; tp1x,tp1y,tp2x,tp2y : gle_shortint; begin with gcbi^, ascii_buffer_ptr(gcbi^.device_buf)^ do if gle_match(4,addr(input_name),4,addr('7580')) or gle_match(4,addr(input_name),4,addr('7570')) or {SFB 9/18/86} gle_match(4,addr(input_name),4,addr('7585')) or gle_match(4,addr(input_name),4,addr('7586')) or gle_match(4,addr(input_name),4,addr('7595')) or {SFB 9/22/86} gle_match(4,addr(input_name),4,addr('7596')) or {SFB 9/22/86} gle_match(4,addr(input_name),4,addr('7575')) or {SFB 11/14/88} gle_match(4,addr(input_name),4,addr('7576')) then {SFB 11/14/88} begin add_char_data ( gcbi, 2, addr('OH') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); tcnt := 1; info1 := gle_read_integer (current,addr(data[1]),cnt); cnt := cnt + tcnt; info3 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info2 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info4 := gle_read_integer (current,addr(data[cnt]),tcnt); current := 0; end else if gle_match(4,addr(input_name),4,addr('7470')) or gle_match(4,addr(input_name),4,addr('7440')) then begin info1 := 0; info2 := 10300; info3 := 0; info4 := 7650; {changed from 7600 per 7550 doc} end else if gle_match(4,addr(input_name),4,addr('7475')) or gle_match(4,addr(input_name),4,addr('7090')) then begin info1 := 0; info2 := 16640; info3 := 0; info4 := 10365; end else if gle_match(4,addr(input_name),4,addr('7550')) then begin info1 := 0; info2 := 16450; info3 := 0; info4 := 10170; end else if gle_match(4,addr(input_name),4,addr('9872')) then begin info1 := 0; info2 := 16000; info3 := 0;  info4 := 11400; end else if gle_match(4,addr(input_name),4,addr('9111')) then begin info1 := 0; info2 := 12032; info3 := 0; info4 := 8704; end else begin { initialize the device and use P1/P2 values } hpgl_get_inpH ut_p1p2 ( gcbi ); tp1x := info1; tp2x := info2; tp1y := info3; tp2y := info4; add_char_data ( gcbi, 2, addr('IN')); hpgl_get_input_p1p2 ( gcbi ); { restore p1, p2 } add_char_data ( gcbi, 2, addr('IP')); add_parm_data ( gcbi, tp1x ); add_char_data ( gcbi, 1, addr(', ')); add_parm_data ( gcbi, tp1y ); add_char_data ( gcbi, 1, addr(', ')); add_parm_data ( gcbi, tp2x ); add_char_data ( gcbi, 1, addr(', ')); add_parm_data ( gcbi, tp2y ); hpgl_flush_buffer ( gcbi ); end; end; procedure hpgl_sample ( gcbi : graphics_input_control_block_ptr ); type byte = 0..255; var cnt : gle_shortint; button : gle_shortint; status : packed record case byte of 0 : (whole : gle_shortint); 1 : (part : packed record bit15,bit14,bit13,bit12,bit11, pen_down, new_cursor, proximity, softkey, srq, error, ready, init, point_ready, bit1, bit0 : boolean; end); end; begin with gcbi^, ascii_buffer_ptr(gcbi^.device_buf)^ do begin add_char_data ( gcbi, 2, addr('OA') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); info1 := gle_read_integer (current,addr(data[1]),cnt); info2 := gle_read_integer (current,addr(data[cnt+1]),cnt); current := 0; input_cpx := info1; input_cpy := info2; add_char_data ( gcbi, 2, addr('OS') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf);  status.whole := gle_read_integer (current,addr(data[1]),cnt); current := 0; if status.part.point_ready then info3 := -1 else if status.part.pen_down then info3 := 1 else info3 := 0; end; end; procedure hpgl_start_digitize ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do begin add_char_data ( gcbi, 8, addr('PU;SG;DP')); hpgl_flush_buffer ( gcbi ); end; end; procedure hpgl_get_digitize ( gcbi : graphics_input_control_block_ptr ); var tcnt,cnt : gle_shortint; begin with gcbi^, ascii_buffer_ptr(gcbi^.device_buf)^ do begin add_char_data ( gcbi, 2, addr('OD') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); tcnt := 1; info1 := gle_read_integer (current,addr(data[1]),cnt); cnt := cnt + tcnt; info2 := gle_read_integer (current,addr(data[cnt]),tcnt); cnt := cnt + tcnt; info3 := gle_read_integer (current,addr(data[cnt]),tcnt); current := 0;  add_char_data ( gcbi, 2, addr('DC') ); hpgl_flush_buffer ( gcbi ); end; end; procedure hpgl_input_echo ( gcbi : graphics_input_control_block_ptr ); begin with gcbi^ do begin if info1 <> 0 then begin add_char_data ( gcbi, 2, addr('BP')); hpgl_flush_buffer ( gcbi ); end; end; end; procedure gle_init_hpgl_input ( gcbi : graphics_input_control_block_ptr); var saved_timeout : integer; i : integer; begin with gcbi^, ascii_buffer_ptr(device_buf)^ do begin try maximum := max_buffer; current := 0; error_return := 0; call (io_inq_timeout, iocb, saved_timeout ); call (io_set_timeout, iocb, 500 { ms } ); { send command that all HPGL plotters can respond to } { if the command fails then the address does not match } { the device. } add_char_data ( gcbi, 2, addr('OE') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); current := 0; { if this point is reached then a vaild HPGL device was found } try { perform an output identify seq. Note a 9872A will fail } add_char_data ( gcbi, 10, addr('IM30;DC;OI') ); hpgl_flush_buffer ( gcbi ); call (io_read, iocb, device_buf); for i := 1 to current do input_name[i] := data[i]; for i := current+1 to 6 do input_name[i] := ' '; input_name_char_count := current; current := 0; recover if escapecode = -26 then begin input_name := '9872A '; input_name_char_count := 5; current := 0; end else escapeI (escapecode); sample := hpgl_sample; start_digitize := hpgl_start_digitize; get_digitize := hpgl_get_digitize; inq_p1p2 := hpgl_get_input_p1p2; input_echo := hpgl_input_echo; input_escapei := hpgl_input_escapei; input_escapeo := hpgl_input_escapeo; input_res_x := 40; input_res_y := 40; input_handler_name := 'HPGL '; input_handler_char_count := 4; hpgl_get_input_hard_clip ( gcbi ); input_min_x := info1; input_max_x := info2; input_min_y := info3; input_max_y := info4; input_cpx := input_min_x; input_cpy := input_min_y; recover if escapecode = -26 then error_return := 1 else escape(escapecode); { ignor io errors } try call (io_set_timeout, iocb, saved_timeout ); recover if escapecode = -26 then error_return := 1 else escape(escapecode); { ignor io errors } end; end; end. { hpgl_input } $tables$ { } { Graphics Low End } { } { Module = GLE_SMARK } { Programer = BJS } { Date = 10-15-82 } {  } { Purpose: To provide software marker routines. } { Rev history } { Created - 10-15-82 BJS  } { Modified - XX-XX-XX } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival  purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ $search 'GLE_AUTL', 'GLE_TYPES'$ $include 'OPTIONS'$ { ******************* COMPILER OPTIONS ******************* } $linenum 5000$ module gle_smark; import gle_types; export procedure gle_soft_marker ( gcb : graphics_control_block_ptr); procedure gle_soft_set_marker ( gcb : graphics_control_block_ptr ); procedure gle_soft_marker_size ( gcb : graphics_control_block_ptr ); implement import gle_autl; procedure gle_soft_marker ( gcb : graphics_control_block_ptr); const marker_cell_shift = -2; { part of marker viewing transformation } type marker_data = -2..2; index_def = 0..50; marker_record = packed record x_pos : marker_data; y_pos : marker_data; penup : boolean; end; mark_def = packed array [1..47] of marker_record; marker_index_def = packed array [1..10] of index_def; const markers = mark_def [ marker_record [x_pos : 0, y_pos : 0, penup : true ], {1} marker_record [x_pos : 0, y_pos : 0, penup : false], {2} marker_record [x_pos : 0, y_pos : 2, penup : true], {3}  marker_record [x_pos : 0, y_pos :-2, penup : false], {4} marker_record [x_pos : 2, y_pos : 0, penup : true], {5} marker_record [x_pos :-2, y_pos : 0, penup : false], {6} marker_record [x_pos : 2, y_pos : 0, penup : true], {7} marker_record [x_pos :-2, y_pos : 0, penup : false], {8} marker_record [x_pos :-2, y_pos : 2, penup : true], {9} marker_record [x_pos : 2, y_pos :-2, penup : false], {10} marker_record [x_pos : 2, y_pos : 2, penup : true], {11} marI ker_record [x_pos :-2, y_pos :-2, penup : false], {12} marker_record [x_pos :-1, y_pos :-2, penup : true], {13} marker_record [x_pos : 1, y_pos :-2, penup : false], {14} marker_record [x_pos : 2, y_pos :-1, penup : false], {15} marker_record [x_pos : 2, y_pos : 1, penup : false], {16} marker_record [x_pos : 1, y_pos : 2, penup : false], {17} marker_record [x_pos :-1, y_pos : 2, penup : false], {18} marker_record [x_pos :-2, y_pos : 1, penup : false], {19} marker_record [x_pos :-2, y_pos :-1, penup : false], {20} marker_record [x_pos :-1, y_pos :-2, penup : false], {21} marker_record [x_pos :-2, y_pos :-2, penup : true], {22} marker_record [x_pos : 2, y_pos : 2, penup : false], {23} marker_record [x_pos :-2, y_pos : 2, penup : true], {24} marker_record [x_pos : 2, y_pos :-2, penup : false], {25} marker_record [x_pos : 0, y_pos : 2, penup : true], {26} marker_record [x_pos : 2, y_pos :-2, penup : false], {27} marker_record [x_pos :-2, y_pos :-2, penup : false], {28} marker_record [x_pos : 0, y_pos : 2, penup : false], {29} marker_record [x_pos :-2, y_pos :-2, penup : true], {30} marker_record [x_pos : 2, y_pos :-2, penup : false], {31} marker_record [x_pos : 2, y_pos : 2, penup : false], {32} marker_record [x_pos :-2, y_pos : 2, penup : false], {33} marker_record [x_pos :-2, y_pos :-2, penup : false], {34} marker_record [x_pos : 0, y_pos : 2, penup : true], {35} marker_record [x_pos : 2, y_pos : 0, penup : false], {36} marker_record [x_pos : 0, y_pos :-2, penup : false], {37} marker_record [x_pos :-2, y_pos : 0, penup : false], {38} marker_record [x_pos : 0, y_pos : 2, penup : false], {39} marker_record [x_pos :-2, y_pos :-2, penup : true], {40} marker_record [x_pos : 2, y_pos :-2, penup : false], {41} marker_record [x_pos : 2, y_pos : 2, penup : false], {42} marker_record [x_pos :-2, y_pos : 2, penup : false], {43} marker_record [x_pos :-2, y_pos :-2, penup : false], {44} marker_record [x_pos : 2, y_pos : 2, penup : false], {45} marker_record [x_pos : 2, y_pos :-2, penup : true], {46} marker_record [x_pos :-2, y_pos : 2, penup : false]]; marker_index = marker_index_def [ {1} 1, {2} 3, {3} 7, {4} 13, {5} 22, {6} 26, {7} 30, {8} 35, {9} 40, {last} 48]; var i : integer; s : packed array [1..1] of char; cpx : gle_shortint; cpy : gle_shortint; dx : gle_shortint; dy : gle_shortint; local_x_pos : gle_shortint; local_y_pos : gle_shortint; saved_char_width : integer; saved_char_height : integer; saved_text_cos_dir : integer; saved_text_sin_dir : integer; saved_line_pattern : integer; saved_linestyle : integer; saved_length : integer; saved_mode : integer; begin with gcb^ do begin saved_mode := current_linestyle_mode; saved_length := current_pattern_length;  saved_linestyle := current_linestyle; saved_line_pattern := current_linestyle_pattern; info1 := 0; info2 := 1; info3 := 0; info4 := -1; call ( linestyle, gcb ); cpx := current_pos_x; cpy := current_pos_y; if marker_type > 9 then begin saved_char_width := char_width; saved_char_height := char_height; saved_text_cos_dir := text_cos_dir; saved_text_sin_dir := text_sin_dir; info1 := marker_width * 8; info2 := marker_height * 8; call ( char_size, gcb ); info1 := 32768; info2 := 0; call ( text_dir, gcb ); s[1] := chr(38+marker_type); end_x := cpx - (marker_width div 2); end_y := cpy - (marker_height div 2); call ( move, gcb ); info_ptr1 := addr(s); info1 := 1; call ( text, gcb ); { restore char state } info1 := saved_char_width; info2 := saved_char_height; call ( char_size, gcb ); info1 := saved_text_cos_dir; info2 := saved_text_sin_dir; call ( text_dir, gcb ); end else for i := markerJ _index[marker_type] to marker_index[marker_type+1]-1 do with markers[i] do begin local_x_pos := x_pos; { move packed field to temp to force type } local_y_pos := y_pos; { to gle_shortint } dx := gle_ishift((local_x_pos * marker_width),marker_cell_shift) + cpx; dy := gle_ishift((local_y_pos * marker_height),marker_cell_shift) + cpy; end_x := dx; end_y := dy; if penup then call ( move, gcb ) else call ( draw, gcb ); end; info1 := saved_linestyle; info2 := saved_length; info3 := saved_mode; info4 := saved_line_pattern; call ( linestyle, gcb ); end_x := cpx; { restore cp } end_y := cpy; call ( move, gcb ); end; end; procedure gle_soft_set_marker ( gcb : graphics_control_block_ptr ); begin with gcb^ do marker_type := info1; end; procedure gle_soft_marker_size ( gcb : graphics_control_block_ptr ); begin with gcb^ do begin marker_width := info1; marker_height := info2; end; end; end. { module gle_smark }  This floppy contains the source for the various Pascal Workstation DGL libraries (GRAPHICS, FGRAPHICS, FGRAPH20). The stream file MAKEDGL.TEXT is an example of a stream file that can be used to build the libraries from the sources. The modcal version of the PaWS Pascal compilers (COMPILER, COMP20) are required to be in the users system directory (*) for this stream file to work. A copy of the Modcal version of COMPILER can be found on the SCSI: source floppy disk, the COMP20 compiler on the RS232: source disk.  This floppy contains the source for the various Pascal Workstation DGL libraries (GRAPHICS, FGRAPHICS, FGRAPH20). The stream file MAKEDGL.TEXT is an example of a stream file that can be used to build the libraries from the sources. The modcal version of the PaWS Pascal compilers (COMPILER, COMP20) are required to be in the users system directory (*) for this stream file to work. A copy of the Modcal version of COMPILER can be found on the SCSI: source floppy disk, the COMP20 compiler on the RS232: source disk. ******************************************************************* Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  This floppy contains the source for the various Pascal Workstation DGL libraries (GRAPHICS, FGRAPHICS, FGRAPH20). The stream file MAKE_DGL.TEXT is an example of a stream file that can be used to build the libraries from the sources. The modcal version of the PaWS Pascal compilers (COMPILER, COMP20) are required to be in the users system directory (*) for this stream file to work. A copy of the Modcal version of COMPILER can be found on the SCSI: source floppy disk, the COMP20 compiler on the RS232: source disk. ******************************************************************* Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product except for archival purposes is prohibited without the prior wJ ritten consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado @@@@@@@@@@@@@@K @@@@@@@@@@@@@@@@K @@@@@@@@@@@@@@@@L @@@@@@@@@@@@@@@@L @@@@@@@@@@@@@@@@