! EDWIN driver for the Apollo
!
! Notes and Revision
!
! 1. Note that ACQUIRE DISPLAY and RELEASE DISPLAY are always called dirctly
! instead of comparing amode with GPR DIRECT always. Note however that
! no status check is carried out afterwards, as it will be # 0 if amode is
! not GPR DIRECT.
! 17-Aug-1988 MM Extend Mouse Keyset for DRAFT
! 9-Jan-1988 JGH Changes to Terminate for iconizing, see SCN 330
from Edwin include Device, Specs
from Imp include Ascii, Lognames
external byte spec Imp Int Flag alias "IMP___INT_FLAG"
external string(31) spec fname
external routine spec User Refresh
external integer spec Font Width alias "CharX"
external integer spec Font Height alias "CharY"
external integer spec Font Descender alias "OffY"
constant short Max Screen Size = 1280
constant short gpr bw portrait = 0,
gpr bw landscape = 1,
gpr color 1024 x 1024 x 4 = 2,
gpr color 1024 x 1024 x 8 = 3,
gpr color 1024 x 800 x 4 = 4,
gpr color 1024 x 800 x 8 = 5,
gpr color 1280 x 1024 x 8 = 6,
grp color1 1024 x 800 x 8 = 7,
grp color2 1024 x 800 x 4 = 8,
grp bw 1280 x 1024 = 9,
Max Known Type = 9
constant short gpr borrow = 0,
gpr frame = 1,
gpr no display = 2,
gpr direct = 3,
gpr borrow nc = 4
constant short gpr solid = 0, gpr dotted = 1
own short gpr ok if obs = 0,
gpr error if obs = 1,
gpr pop if obs = 2,
block if obs = 3
own short gpr keystroke = 0,
gpr buttons = 1,
gpr locator = 2,
gpr entered window = 3,
gpr left window = 4,
gpr locator stop = 5,
gpr no event = 6,
gpr locator update = 7,
gpr dial = 8
record format gpr position t (short x coord, y coord)
record format gpr offset t (short x size, y size)
record format gpr window t (record (gpr position t) window base,
record (gpr offset t) window size)
record format gpr horiz seg t (short x coord l, x coord r, y coord)
record format gpr trap t (record (gpr horiz seg t) top, bot)
external routine spec gpr init alias "GPR_$INIT" ( c
short name op,
short name unit or pad,
record(gpr offset t) name size,
short name hi plane,
integer name init bitmap,
integer name status)
external routine spec gpr terminate alias "GPR_$TERMINATE" ( c
integer name delete disp,
integer name status)
external routine spec gpr set cursor active c
alias "GPR_$SET_CURSOR_ACTIVE" ( c
integer name active,
integer name status)
external routine spec gpr set cursor origin c
alias "GPR_$SET_CURSOR_ORIGIN" (c
record(gpr position t) name pos,
integer name status)
external routine spec gpr set cursor position c
alias "GPR_$SET_CURSOR_POSITION" (c
record(gpr position t) name pos,
integer name status)
external routine spec gpr set cursor pattern c
alias "GPR_$SET_CURSOR_PATTERN" (c
integer name bitmap desc,
integer name status)
external routine spec gpr allocate bitmap c
alias "GPR_$ALLOCATE_BITMAP" (c
record(gpr offset t) name size,
short name hi plane,
integer name attr,
integer name bitmap,
integer name status)
external routine spec gpr set bitmap c
alias "GPR_$SET_BITMAP" (c
integer name bitmap,
integer name status)
external routine spec gpr deallocate bitmap c
alias "GPR_$DEALLOCATE_BITMAP" ( c
integer name bitmap,
integer name status)
external routine spec gpr allocate attribute block c
alias "GPR_$ALLOCATE_ATTRIBUTE_BLOCK" ( c
integer name attrib,
integer name status)
external routine spec gpr deallocate attribute block c
alias "GPR_$DEALLOCATE_ATTRIBUTE_BLOCK" ( c
integer name attrib,
integer status)
external routine spec gpr set attribute block c
alias "GPR_$SET_ATTRIBUTE_BLOCK" ( c
integer name attrib,
integer name status)
external routine spec gpr set text font c
alias "GPR_$SET_TEXT_FONT" ( c
short name font id,
integer name status)
external routine spec gpr set coordinate origin c
alias "GPR_$SET_COORDINATE_ORIGIN" ( c
record(gpr position t) name origin,
integer name status)
external routine spec gpr set draw value c
alias "GPR_$SET_DRAW_VALUE" ( c
integer name val,
integer name status)
external routine spec gpr set text value c
alias "GPR_$SET_TEXT_VALUE" ( c
integer name val,
integer name status)
external routine spec gpr set text background value c
alias "GPR_$SET_TEXT_BACKGROUND_VALUE" ( c
integer name val,
integer name status)
external routine spec gpr set fill value c
alias "GPR_$SET_FILL_VALUE" ( c
integer name val,
integer name status)
external routine spec gpr set raster op c
alias "GPR_$SET_RASTER_OP" ( c
short name plane,
short name op,
integer name status)
external routine spec gpr set line pattern c
alias "GPR_$SET_LINE_PATTERN" ( c
short name repeat,
short name pattern,
short name length,
integer name status)
external routine spec gpr set linestyle c
alias "GPR_$SET_LINESTYLE" ( c
short name style,
short name scale,
integer name status)
external routine spec gpr inq constraints c
alias "GPR_$INQ_CONSTRAINTS" ( c
record(gpr window t) name window,
integer name active { boolean },
short name mask,
integer name status)
external routine spec gpr inq text c
alias "GPR_$INQ_TEXT" ( c
short name font id,
short name path,
integer name status)
external routine spec gpr inq coordinate origin c
alias "GPR_$INQ_COORDINATE_ORIGIN" ( c
record(gpr position t) name origin,
integer name status)
external routine spec gpr inq draw value c
alias "GPR_$INQ_DRAW_VALUE" ( c
integer name val,
integer name status)
external routine spec gpr inq text values c
alias "GPR_$INQ_TEXT_VALUES" ( c
integer name tval,
bval,
integer name status)
external routine spec gpr inq fill value c
alias "GPR_$INQ_FILL_VALUE" (c
integer name val,
integer name status)
external routine spec gpr inq raster ops c
alias "GPR_$INQ_RASTER_OPS" ( c
short name ops,
integer name status)
external routine spec gpr inq linestyle c
alias "GPR_$INQ_LINESTYLE" ( c
short name style,
short name scale,
integer name status)
external routine spec gpr inq bitmap dimensions -
alias "GPR_$INQ_BITMAP_DIMENSIONS" (-
integer name Bitmap Desc, record (Gpr Offset T) name Size,
short name Hi Plane Id, integer name Status)
external routine spec gpr set bitmap dimensions -
alias "GPR_$SET_BITMAP_DIMENSIONS" (-
integer name Bitmap Desc, record (Gpr Offset T) name Size,
short name Hi Plane Id, integer name Status)
external routine spec gpr move alias "GPR_$MOVE" ( c
short name x,y,
integer name status)
external routine spec gpr inq cp alias "GPR_$INQ_CP" (c
short name x,y,
integer name status)
external routine spec gpr line alias "GPR_$LINE" ( c
short name x,y,
integer name status)
external routine spec gpr load font file c
alias "GPR_$LOAD_FONT_FILE" ( c
byte name pn,
short name pnlen,
short name font id,
integer name status)
external routine spec gpr unload font file c
alias "GPR_$UNLOAD_FONT_FILE" ( c
short name font id,
integer name status)
external routine spec gpr text alias "GPR_$TEXT" ( c
byte name str,
short name strl,
integer name status)
external routine spec gpr inq text extent c
alias "GPR_$INQ_TEXT_EXTENT" ( c
byte name str,
short name strl,
record(gpr offset t) name size,
integer name status)
external routine spec gpr inq text offset c
alias "GPR_$INQ_TEXT_OFFSET" ( c
byte name str,
short name strl,
record(gpr offset t) name start,
short name x end,
integer name status)
external routine spec gpr clear alias "GPR_$CLEAR" ( c
integer name val,
integer name status)
external routine spec gpr pixel blt c
alias "GPR_$PIXEL_BLT" ( c
integer name src b,
record (gpr window t) name src w,
record (gpr position t) name dst o,
integer name status)
external routine spec gpr bit blt c
alias "GPR_$BIT_BLT" ( c
integer name src b,
record (gpr window t) name src w,
short name src p,
record (gpr position t) name dst o,
short name dst p,
integer name status)
external routine spec gpr additive blt c
alias "GPR_$ADDITIVE_BLT" ( c
integer name src b,
record (gpr window t) name src w,
short name src p,
record(gpr position t) name dst o,
integer name status)
external routine spec gpr rectangle c
alias "GPR_$RECTANGLE" ( c
record(gpr window t) name rect,
integer name status)
external routine spec gpr set obscured opt c
alias "GPR_$SET_OBSCURED_OPT" ( c
short name if obscured, integer name status)
external integer function spec gpr acquire display c
alias "GPR_$ACQUIRE_DISPLAY" ( c
integer name status)
external routine spec gpr force release c
alias "GPR_$FORCE_RELEASE" ( c
short name acq rel cnt, integer name status)
external routine spec gpr release display c
alias "GPR_$RELEASE_DISPLAY" ( c
integer name status)
external byte function spec gpr event wait c
alias "GPR_$EVENT_WAIT" ( c
short name event type, byte name event data,
record (gpr position t) name pos, integer name status)
external byte function spec gpr cond event wait c
alias "GPR_$COND_EVENT_WAIT" ( c
short name event type, byte name event data,
record (gpr position t) name pos, integer name status)
external routine spec gpr enable input c
alias "GPR_$ENABLE_INPUT" ( c
short name event type, short name key set, integer name status)
external routine spec gpr disable input c
alias "GPR_$DISABLE_INPUT" ( c
short name event type, integer name status)
external routine spec gpr inq cursor c
alias "GPR_$INQ_CURSOR" ( c
integer name cursor pattern, short name raster op, integer name active,
record(gpr position t) name position, record(gpr position t) name origin,
integer name status)
external routine spec gpr set auto refresh c
alias "GPR_$SET_AUTO_REFRESH" ( c
integer name auto refresh, integer name status)
external routine spec gpr set clip window c
alias "GPR_$SET_CLIP_WINDOW" ( c
record (gpr window t) name window, integer name status)
external routine spec gpr set clipping active c
alias "GPR_$SET_CLIPPING_ACTIVE" ( c
integer name active, integer name status)
external routine spec gpr polyline c
alias "GPR_$POLYLINE" ( c
short name x,y, short name npoints, integer name status)
external routine spec gpr pgon polyline c
alias "GPR_$PGON_POLYLINE" ( c
short name x,y, short name npoints, integer name status)
external routine spec gpr start pgon c
alias "GPR_$START_PGON" ( c
short name x,y, integer name status)
external routine spec gpr close fill pgon c
alias "GPR_$CLOSE_FILL_PGON" ( c
integer name status)
external routine spec gpr close return pgon tri -
alias "GPR_$CLOSE_RETURN_PGON_TRI" ( -
short name List Size, T List, N Triangles, integer name status)
external routine spec gpr multitriangle -
alias "GPR_$MULTITRIANGLE" ( -
short name T List, N Triangles, integer name status)
external routine spec gpr pgon decomp technique -
alias "GPR_$PGON_DECOMP_TECHNIQUE" (-
short name Decomp Technique, integer name Status)
external routine spec Gpr Set colour map alias "GPR_$SET_COLOR_MAP" ( c
integer name index,
short name nentries,
integer name values, { dodgy array }
integer name status)
external routine spec Set Plane Mask 32 alias "GPR_$SET_PLANE_MASK_32" ( c
integer name mask,
integer name status)
external routine spec Set Fill Pattern alias "GPR_$SET_FILL_PATTERN" ( c
integer name pattern,
short name scale,
integer name status)
external routine spec Set Line Pattern alias "GPR_$SET_LINE_PATTERN" ( c
short name repeat,
short name pattern, { dodgy - array }
short name length,
integer name status)
external routine spec Gpr Inq Config alias "GPR_$INQ_CONFIG" ( c
short name format,
integer name status)
external routine spec Gpr Circle alias "GPR_$CIRCLE" ( c
record(gpr position t) name center,
short name radius,
integer name status)
external routine spec Gpr Circle Filled alias "GPR_$CIRCLE_FILLED" ( c
record(gpr position t) name center,
short name radius,
integer name status)
external routine spec Gpr Draw box alias "GPR_$DRAW_BOX" ( c
record(gpr position t) name c1,c2,
integer name status)
external routine spec Gpr Close Return Pgon alias "GPR_$CLOSE_RETURN_PGON" ( c
short name list size,
record (gpr trap t) name trapesiod list,
short name trapesiod number,
integer name status)
external routine spec Gpr Multitrapeziod alias "GPR_$MULTITRAPEZOID" ( c
record (gpr trap t) name trapesiod list,
short name trapesiod number,
integer name status)
external routine spec Gpr Triangle alias "GPR_$TRIANGLE" (c
record (gpr position t) name vertex 1, vertex 2, vertex 3,
integer name status)
! PAD System services for window control
constant integer pad transcript = 0,
pad input = 1,
pad edit = 2, {already declared}
pad read edit = 3
record format pad window desc t (short top,left,width,height)
external routine spec pad create window alias "PAD_$CREATE_WINDOW" ( c
byte name n,short name l,short name ptype,
short name unit,record(pad window desc t) name window,
short name rslt stream,
integer name status)
external routine spec Pad Inq Font alias "PAD_$INQ_FONT" (short name -
stream, width, height, integer name name, short name size, Len,
integer name status)
external routine spec Pad Inq Window alias "PAD_$INQ_WINDOWS" (-
short name stream, short array name list,
short name size, number, integer name status)
external routine spec pad make icon alias "PAD_$MAKE_ICON" (c
short name Sid, Wid, byte name icon char, integer name status)
external routine spec pad Select Window alias "PAD_$SELECT_WINDOW" (c
short name Sid, Wid, integer name status)
external routine spec pad set auto close alias "PAD_$SET_AUTO_CLOSE" ( c
short name sid, wid, integer name auto close, status)
external routine spec pad set Icon Font alias "PAD_$SET_ICON_FONT" ( c
short name sid, wid,
byte name font name,
short name font len, integer name status)
!********************************************************************
own integer screen width = Max Screen Size, screen height = Max Screen Size
const integer ok = 0
! Screen information
own short SX = 0
own short SY = 0
own integer XL = 0
own integer XR = Max Screen Size; !Right hand side of device window
own integer YB = 0
own integer YT = Max Screen Size
own short raster op = 3{ Overwrite mode by default }
own short AMODE = GPR Direct
own integer CCOL = 7 { White as Current Colour
own short SHADE MODE = 0 { Outline, #0 => Solid or patterns
own short Redraw Flag = 0
own short Refresh Flag = 0
routine SWAP (integer name A, B)
integer C
C = A; A = B; B = C
end
own short array mouse keyset (1 : 16) = 0(8), -1(*)
own short array keyset (1 : 16) = C
0, {2_0000000000000000 1 - 240 -255}
0, {2_0000000000000000 2 - 224 -239}
0, {2_0000000000000000 3 - 208 -223}
0, {2_0000000000000000 4 - 192 -207}
0, {2_0000000000000000 5 - 176 -191}
0, {2_0000000000000000 6 - 160 -175}
2_0000000001100000,{ 7 - 144 -159} {return & bs}
2_0101010100000000,{ 8 - 128 -143} {arrow keys}
-1, {2_1111111111111111 9 - 112 -127}
-1, {2_1111111111111111 10 - 96 -111}
-1, {2_1111111111111111 11 - 80 - 95}
-1, {2_1111111111111111 12 - 64 - 79}
-1, {2_1111111111111111 13 - 48 - 63}
-1, {2_1111111111111111 14 - 32 - 47}
2_0011111111111111,{ 15 - 16 - 31} {not ^P & ^Q}
-1 {2_1111111111111111 element 16 - char 0 - 15}
const integer black = 0, white = 1
own short bitmap width = 256,{ the x size of the bitmap}
bitmap height = 256,{ the y size of the bitmap}
zero = 0, one = 1, dummy = 0,
max plane num = 3,
this window = 1
own integer true = -1, false = 0
own short len, pad type, radius, line mode, line length
record format font fm (short f id, byte max x, maxy)
own record(font fm) text font1 = 0, text font2 = 0, text font3 = 0
own record(gpr offset t) end = 0
own short endx = 0, endy = 0
own short stream = 1, window stream = 0,
event type,
repeat x = 15
own integer display desc, bitmap desc, cursor desc, attribute desc,
status, obscured
include "polyfill.apo"
external string(255) function spec sysmess alias "IMP_SYSTEM_MESSAGE" (integer status)
external routine APOLLO MODE alias "EDWIN_APOLLO_MODE" (integer X)
AMODE = X if gpr direct=X or gpr borrow=X or gpr frame=X
end
own string(127) buffer = ""
routine print text
short len
byte name ptr
ptr == charno(buffer,1); len=length(buffer)
obscured = gpr acquire display(status)
gpr text(ptr,len,status)
gpr release display(status)
buffer = ""
end
own short nlines = 0
record format Data Fm (short x, y, record (Data Fm) name Next)
own record (Data fm) name Point List == 0
own record (Data fm) name Next point == 0
routine draw lines
short array xline (1:nlines)
short array yline (1:nlines)
record (Data fm) name PP
integer i
integer dummy
return if nlines = 0 and Point List == Nil
pp == point list
for I = 1, 1, Nlines cycle
xline(i) = pp_x
yline(i) = pp_y
pp == pp_next
repeat
obscured = gpr acquire display(status)
if Shade Mode = 0 or nlines<=2 start
gpr polyline(xline(1),yline(1),nlines,status)
if status # ok start
gpr release display(dummy)
printstring("Draw line fails. Status = ".itos(status,0).snl)
stop
finish
else if Shade Mode = 1
gpr start pgon (xline(1), yline(1), status)
nlines = nlines - 1
gpr pgon polyline (xline(2), yline(2), nlines, status)
gpr close fill pgon (status)
else
polyfill (ccol, nlines, xline, yline)
finish
gpr release display(status)
nlines = 0
end
routine add line(integer x,y)
if Nlines = 0 start
point list_x = sx; point list_y = sy
Next point == point list
Nlines = 1
finish
Nlines = Nlines + 1
if Next point_next == Nil start
Next point_next == New (Next point)
Next point == Next point_next
Next point_next == Nil
else
Next point == next point_next
finish
next point_x = x; next point_y = y
end
routine update dd
draw lines if nlines > 0
print text if buffer # ""
end
own integer array colour map (0:256) = 0, 16_FF0000, 16_FF00,
16_FFFF00, 16_FF, 16_FF00FF, 16_FFFF, 16_FFFFFF, 0 (*)
own record (gpr offset t) new bitmap size, old bitmap size
external routine spec Apollo alias "EDWIN___C" (integer Com, X, Y)
routine Deal With Possible Resize
unless Dev Data_Max Colour = 0 start
radius = 7 { false = 0 already }
gpr set colour map (false, radius, colour map (0), status)
finish
gpr inq bitmap dimensions (Display Desc, new bitmap size, Radius, Status)
unless New bitmap size_x size = Old Bitmap size_x size and -
New bitmap size_y size = Old Bitmap size_y size start
if Fname = "DRAFT" start
if New bitmap size_y size > 500 start
gpr set text font(text font1_f id, status)
Font Width = 7
Font Height = 14
Font Descender = 4
else if New Bitmap Size_y size > 300
gpr set text font(text font2_f id, status)
Font Width = 5
Font Height = 10
Font Descender = 3
else
gpr set text font(text font3_f id, status)
Font Width = 4
Font Height = 8
Font Descender = 2
finish
finish
Apollo (3, 0, 0)
User Refresh
finish
end
external routine APOLLO alias "EDWIN___C" (integer COM, X, Y)
own integer array MAP (0:7) = 0, 7, 4, 2, 1, 5, 3, 6
own integer WX, WY, fill value
own short counter, just initialised = 0
byte name ptr
byte char
integer height, width, x dist, y dist, Loop count
record (gpr offset t) ss, bitmap size, dummy
record (gpr window t) win, source win
record (pad window desc t) pwin
record (gpr position t) origin, p1
string (127) file
switch SW, AS (0:15)
routine abort
integer Dummy
gpr release display(Dummy) { Just in case it was claimed }
Printstring ("Output command ".ItoS(Com,0)." fails : ".sysmess(status) )
newline
monitor if Translate ("LL_DIAG") # "LL_DIAG"
stop
end
routine set background colour(integer colour)
fill value = colour
gpr clear(fill value,status)
if colour & 1 = 0 then fill value = white else fill value = black
fill value = Map(white) if fill value = white and Dev Data_Max Colour>0
gpr set draw value(fill value,status)
end
routine horizontal line(integer incr)
integer i
for i = 0, incr, bitmap height cycle
len = i
gpr move(zero,len,status)
gpr line(bitmap width,len,status)
repeat
end
routine vertical line(integer incr)
integer I
for i = 0, incr, bitmap width cycle
len = i
gpr move(len,zero,status)
gpr line(len,bitmap height,status)
repeat
end
routine right diagonal(integer incr)
integer i
for i = 0, incr, bitmap width cycle
len = i
gpr move(zero,len,status)
gpr line(len,zero,status)
gpr move(bitmap height,len,status)
gpr line(len,bitmap width,status)
repeat
end
routine left diagonal(integer incr)
integer i
short dummy
for i = 0, incr, bitmap width cycle
len = i
dummy = bitmap width - len
gpr move(len,zero,status)
gpr line(bitmap width,dummy,status)
gpr move(dummy,bitmap width,status)
gpr line(zero,len,status)
repeat
end
routine Get Int (string (127) Value, short name Thing, integer default)
string (127) T Value
on 3,4,9 start
Oper Message ("Invalid setting for ".Value)
stop
finish
TValue = Translate (Value)
Thing = Default and return if TValue = Value
Thing = S to I (TValue)
end
routine Set Raster Op (integer Raster Op)
integer loop count
short plane, Op
Op = Raster Op
for Loop Count = 0, 1, max plane num cycle
plane = loop count
gpr set raster op (plane, op, status)
abort if status # ok
repeat
end
on 9 start
Oper Message ("Apollo Graphics Error: ".Sys Mess (Event_Extra))
signal 14, 1
finish
print text if buffer # "" and com # 6
draw lines if nlines # 0 and com # 5
counter = counter + 1
if counter & 64 # 0 start
counter = 0
obscured = gpr acquire display(status)
width = gpr cond event wait (event type, char, origin, status)
if event type = gpr keystroke start
if Interrupted start; finish
IMP Int Flag = 1 if char=Etx or char=Del
else if event type = gpr entered window
if Fname = "DRAFT" start
Redraw Flag = 1
else
Deal With Possible Resize
finish
finish
gpr release display(status)
finish
! Oper Message("Device driven with ".itos(com,0).itos(x,3).itos(y,3))
-> SW(COM)
SW(0): ! Initialise
if fname = "DRAFT" start
Font Width = 7
Font Height = 14
Font Descender = 4
! extend keyset to include function keys
keyset (2) = 2_0000011100000000; ! L1A, l2A, L3A
keyset (4) = 2_0000000011111111; ! F1 - F8
keyset (8) = 2_1111111111111110; ! Left Keypad
finish
if Amode=gpr direct start
if Window Stream = 0 start
sx = 1 { Unit no. }
file = ""
ptr == charno (file,1)
len = length(file)
Get int ("EDWIN_APOLLO_LEFT", pwin_left, 0)
Get int ("EDWIN_APOLLO_TOP", pwin_top, 0)
Get int ("EDWIN_APOLLO_WIDTH", ss_X Size, 1000)
Get int ("EDWIN_APOLLO_HEIGHT", ss_Y Size, 800)
pwin_width = ss_xsize + 8
pwin_height = ss_ysize
pad type = pad transcript
pad create window (ptr, len, pad type, sx, pwin, window stream, status)
abort if status # ok
pad set auto close (window stream, this window, true, status)
abort if status # ok
file = Translate(Fname."_ICON")
if file # Fname."_ICON" start
sy = length(file)
pad set icon font (window stream, this window, charno(file,1),
sy, status)
abort if status # ok
finish
else
pad select window (window stream, this window, status)
abort if status # ok
if Fname = "DRAFT" start
Redraw Flag = 1
Refresh Flag = 1
finish
finish
stream = window stream
else
stream = 1
finish
ss_x size = Max screen size
ss_y size = Max screen size
gpr init (amode, stream, ss, max plane num, display desc, status)
abort if status # ok
gpr set auto refresh (true, status)
gpr inq bitmap dimensions (Display Desc, bitmap size, Radius, Status)
old bitmap size = bitmap size
Screen Width = Bitmap size_X size
Screen Height = Bitmap size_Y size - 1
if Radius = 0 start
Max Plane Num = 0
DEV DATA_MAX COLOUR = 0
else
Max Plane Num = 3
DEV DATA_MAX COLOUR = 7
finish
gpr allocate attribute block(attribute desc,status)
abort if status # ok
bitmap size_x size = bitmap width
bitmap size_y size = bitmap height
gpr allocate bitmap(bitmap size, Max Plane Num, attribute desc,
bitmap desc, status)
abort if status # ok
gpr allocate attribute block(attribute desc,status)
abort if status # ok
bitmap size_x size = 16
bitmap size_y size = 16
gpr allocate bitmap(bitmap size, Max Plane Num, attribute desc,
cursor desc, status)
abort if status # ok
gpr set bitmap(display desc, status)
abort if status # ok
gpr set obscured opt (gpr pop if obs, status)
mouse keyset(fill value) = 0 for fill value = 9, 1, 16
mouse keyset(10) = 2_1110 { to enable "a", "b", "c" for mouse }
file = Translate ("EDWIN_APOLLO_FONT")
if file = "EDWIN_APOLLO_FONT" start
if Fname = "DRAFT" start
file = "/sys/dm/fonts/helvetica12" { The standard text font }
else
file = "/sys/dm/fonts/std.19l" { The standard text font }
! This one seems to be the only one which works for Artview!
finish
finish
ptr == charno (file,1)
len = length(file)
gpr load font file(ptr,len,text font1_f id, status)
abort if status # ok
file = "/sys/dm/fonts/helvetica9"
len = length(file)
gpr load font file(ptr,len,text font2_f id, status)
abort if status # ok
file = "/sys/dm/fonts/helvetica7"
len = length(file)
gpr load font file(ptr,len,text font3_f id, status)
abort if status # ok
gpr set text font(text font1_f id, status)
abort if status # ok
file = "w"; ptr == charno(file,1); len = 1
gpr inq text extent(ptr,len,end,status)
text font1_maxx = end_x size if end_x size > text font1_max x
text font1_maxy = end_y size if end_y size > text font1_max y
gpr set bitmap(cursor desc, status)
obscured = gpr acquire display(status)
set background colour(black)
for Loop Count = 7, 1, 9 cycle
endx = Loop Count
gpr move(endx,zero,status)
gpr line(endx,repeat x,status)
gpr move(zero, endx,status)
gpr line(repeat x, endx,status)
repeat
gpr set cursor pattern(cursor desc, status)
abort if status # ok
origin_x coord = 8; origin_y coord = 8
gpr set cursor origin(origin, status)
abort if status # ok
gpr set bitmap(display desc, status)
abort if status # ok
set background colour(black)
unless Dev Data_Max Colour = 0 start
radius = 7
gpr set colour map (false, radius, colour map (0), status)
finish
gpr enable input (gpr entered window, zero, status)
abort if status # ok
gpr enable input (gpr keystroke, keyset(1), status)
abort if status # ok
gpr release display(status)
Point List == New (point list) if Point List == Nil
point List_next == Nil
DEV DATA_NAME = "an Apollo Workstation"
DEV DATA_DVX = Screen width - 1
DEV DATA_DVY = Screen Height - 1
DEV DATA_MVX = Screen width - 1
DEV DATA_MVY = Screen Height - 1
Just Initialised = True
return
SW(1): ! Terminate
gpr terminate (false, status)
abort if status # ok
char = Charno (Fname, 1)
pad make icon (window stream, this window, char, status)
abort if status # ok
return
SW(2): ! Update
return
SW(3): ! Newframe
! %if amode = Gpr direct %and Just Initialised = False %start
! com = ccol
! y = Shade Mode
! gpr terminate (false, status)
! abort %if status # ok
! Apollo (0, 0, 0); { This gives us the new bitmap size (if any) }
! ccol = com
! Shade Mode = y
! Just Initialised = False
! %finish
if Device Data_Max Colour > 0 start
X = 7; set plane mask 32 (X, status)
finish
obscured = gpr acquire display (status)
gpr clear (false, status)
gpr release display (status)
gpr inq bitmap dimensions (Display Desc, new bitmap size, Radius, Status)
sx = 0
Screen height = New bitmap size_Y Size - 1
sy = screen height
Device Data_MVX = New bitmap size_X size
Device Data_MVY = Screen Height - 1
Old Bitmap Size = New Bitmap Size
Viewport (0, New bitmap size_x size, 0, New bitmap size_y size)
gpr set bitmap(display desc,status)
abort if status # ok
Set Raster Op (Raster Op)
Apollo (7, 0, CCol)
gpr set linestyle (line mode, Line Length, status)
Apollo (7, 10, Shade Mode)
return
SW(4): ! Move
sx = x
sy = screen height - y
gpr move (sx, sy, status)
abort if status # ok
return
SW(5): ! Line
sx = x
sy = screen height - y
add line(sx,sy)
return
SW(6): ! Char
length(buffer) = length(buffer) + 1
charno(buffer,length(buffer)) = x
print text if length(buffer) = 127
return
SW(7): ! Attribute
return unless 0 <= X <= 15
-> AS (X)
AS(0): ! Set Colour
CCol = Y
if Dev Data_Max Colour # 0 start
gpr set draw value (map(y), status)
gpr set fill value (map(y), status)
gpr set text value (map(y), status)
if rasterop = 7 start { OR mode }
Y = map(y)
else
Y = 7
finish
set plane mask 32 (Y, status)
gpr set text background value (false, status)
else
if y=0 then fill value=black else fill value = white
gpr set draw value (fill value, status)
gpr set fill value (fill value, status)
gpr set text value (fill value, status)
if y=1 then fill value=black else fill value = white
gpr inq fill value (fill value, status)
finish
return
AS(1): ! Line Style
if y=0 start
line mode = gpr solid
else
line mode = gpr dotted
finish
Line Length = 5 * y { actually the line style required! }
gpr set linestyle (line mode, Line Length, status)
abort if status # ok
return
AS(9): ! Colour Mode
if y=0 start
raster op = 3 { OVERWRITE mode }
else if y=1
raster op = 1 { AND mode }
else if y=2
raster op = 7 { OR mode }
else if y=3
Raster op = 6 { XOR mode }
else if y=4
Raster op = 10 { Invert mode }
finish
gpr set bitmap(display desc,status)
abort if status # ok
Set Raster Op (Raster Op)
Y = ccol; X = 0
-> AS (0)
AS(10): ! Shade Mode
Shade Mode = Y
obscured = gpr acquire display(status)
gpr set bitmap(bitmap desc, status)
set background colour(black)
X = 7
set plane mask 32 (X, status)
set raster op (3) { Overwrite mode }
if y=0 or y=1 start { Solid }
! Don't do anything, leave alone
else if y=2
Horizontal line (4)
else if y=3
Vertical Line (4)
else if y=4 { Left Diagonal }
Left diagonal(4)
else if y=5 { Right Diagonal }
right diagonal(4)
else if y=6
Left Diagonal (4)
Right Diagonal (4)
else if y=7
Horizontal line (4)
Vertical Line (4)
else if y=8
left diagonal(4)
fill value = black
gpr set draw value(fill value,status)
! Horizontal line (2), but offset by 1 to give better stipple overlap
for Loop Count = 1, 2, bitmap height-1 cycle
len = Loop Count
gpr move(zero,len,status)
gpr line(bitmap width,len,status)
repeat
else if y=9
for x = 0, 8, bitmap width - 8 cycle
for y = 0, 8, bitmap height - 8 cycle
for com = 0, 1, 3 cycle
endx = x + com
endy = y
gpr move(endx, endy,status)
endy = y + 4
gpr line(endx, endy, status)
repeat
for com = 0, 1, 3 cycle
endx = x + com + 4
endy = y + 4
gpr move(endx, endy,status)
endy = y + 8
gpr line(endx, endy, status)
repeat
repeat
repeat
else if y=10 { Bricks }
horizontal line (4)
for Loop Count = 0, 16, bitmap width - 16 cycle
len = Loop Count
for x = 0, 8, bitmap height - 8 cycle
endx = x
endy = x + 4
gpr move(len,endx,status)
gpr line(len,endy,status)
radius = len + 8
endx = endx + 4
endy = endy + 4
gpr move(radius,endx,status)
gpr line(radius,endy,status)
repeat
repeat
else
! Treat the style as if it was Solid
finish
gpr release display(status)
gpr set bitmap (display desc, status)
AS(*): return { Ignore any other attributes }
SW(8): ! Lower window bounds
XL = X; YB = Y
return
SW(9): ! Upper window bounds
XR = X; YT = Y
! ! Now to set the clip
! win_window base_x coord = xl
! win_window base_y coord = screen height - yt
! win_window size_x size = xr-xl+1
! win_window size_y size = yt-yb+1
! gpr set clip window (win, status)
! abort %if status # ok
! gpr set clipping active (true, status)
! abort %if status # ok
return
SW(10):
if Shade Mode = 0 start
! Cheat to match line style stuff on the Whitechapel
begin
own short array pattern (1:4) = 16_FFFF8000, 0(*)
own short repeat = 1,length = 1
if x = 2 start
! try to draw the first dot (last dot would be difficult)
repeat = 1 ; length = 64
else if x = 0
repeat = 0 ; length = 1 ;! set repeat to 0 to ignore pattern
finish
gpr set line pattern(repeat,pattern(1),length,status)
abort if status # ok
end
finish
return
SW(11): ! Overwrite mode
Y = X; X = 9
-> SW(7)
SW(12): ! Remember lower box bounds
WX = X; WY = Y
return
SW(13): ! Upper box bounds & do the box
swap (wx, x) if wx > x
swap (wy, y) if wy > y
return if WX > XR or X < XL or WY > YT or Y < YB
WX = XL if WX < XL
WY = YB if WY < YB
X = XR if X > XR
Y = YT if Y > YT
! Box now clipped into the screen.
obscured = gpr acquire display(status)
win_window base_x coord = wx
win_window base_y coord = screen height - y
win_window size_x size = x-wx
win_window size_y size = y-wy
if Shade Mode = 0 start
endx = win_window base_x coord; endy = win_window base_y coord
gpr move(endx, endy, status)
endx = endx + win_window size_x size { Now to frame it }
gpr line(endx, endy, status)
endy = endy + win_window size_y size
gpr line(endx, endy, status)
endx = endx - win_window size_x size
gpr line(endx, endy, status)
endy = endy - win_window size_y size
gpr line(endx, endy, status)
else
if Shade Mode > 1 start
height = y - wy; width = x - wx { Dimension of rectangle }
y dist = win_window base_y coord & repeat x
origin_y coord = win_window base_y coord
while height > 0 cycle
source win_window base_y coord = y dist
if height > bitmap height - y dist start
source win_window size_y size = bitmap height - y dist
else
source win_window size_y size = height
finish
origin_x coord = win_window base_x coord
x dist = win_window base_x coord & repeat x
while width > 0 cycle
source win_window base_x coord = x dist
if width > bitmap width - x dist start
source win_window size_x size = bitmap width - x dist
else
source win_window size_x size = width
finish
gpr pixel blt(bitmap desc, source win, origin, status)
width = width - source win_window size_x size
origin_x coord = origin_x coord + source win_window size_x size
x dist = 0 { for every other time round the loop }
repeat
width = x - wx { Reset the width }
height = height - source win_window size_y size
origin_y coord = origin_y coord + source win_window size_y size
y dist = 0 { for every other time round the loop }
repeat
endx = win_window base_x coord; endy = win_window base_y coord
gpr move(endx, endy, status)
endx = endx + win_window size_x size { Now to frame it }
gpr line(endx, endy, status)
endy = endy + win_window size_y size
gpr line(endx, endy, status)
endx = endx - win_window size_x size
gpr line(endx, endy, status)
endy = endy - win_window size_y size
gpr line(endx, endy, status)
else
gpr inq fill value(fill value,status)
if raster op = 10 {invert} start
origin_x coord = 0 ; origin_y coord = 0
p1 = win_window base
zero = 0
gpr set bitmap(display desc,status)
abort if status # ok
begin
short array raster ops(0 : 7)
integer loop count
abort if status # ok
gpr inq raster ops(raster ops(0),status)
abort if status # ok
end
gpr pixel blt(display desc,win,p1,status)
abort if status # ok
else
gpr rectangle (win, status)
finish
finish
finish
gpr release display(status)
return
SW(14): ! Circle
p1_x coord = sx; p1_y coord = sy; Radius = X
obscured = gpr acquire display(status)
if Shade mode = 0 start
Gpr Circle (p1, Radius, status)
else
Gpr Circle Filled (p1, Radius, status)
finish
gpr release display(status)
return
SW(15): ! Area fill
end
!%external %routine draw dots %alias "EDWIN_DRAW_DOTS" ( -
! %integer lx,ly,hx,hy,gap)
! %record(gpr window t) clip win,rect win,dot win
! %integer active,i
! %integer lx1,ly1,hx1,hy1
! %short x,y,x1,y1
! %own %short plane = 0
! %short %array rasters (0:7)
! %record(gpr position t) p1
!
! %from edwin %include specs
!
! %routine abort
! %integer dummy
! gpr release display(Dummy) { Just in case it was claimed }
! Printstring ("EDWIN_DRAW_DOTS fails : ".sysmess(status) )
! newline
! %stop
! %end
!
! !
! ! first save all the interesting attributes
! !
! update dd ;! draw anything outstanding
! gpr set bitmap(display desc,status)
! gpr inq constraints(clip win,active,plane,status)
! gpr inq raster ops(rasters(0),status)
! x = 0 ; y = 3
! %for i = 0, 1, max plane num %cycle
! x = i
! gpr set raster op(x,y,status)
! %repeat
! !
! ! get the bounding box for clipping
! !
! lx1 = lx ; ly1 = ly ; hx1 = hx ; hy1 = hy
! map to device coords(lx,ly) ; ly = screen height - ly
! map to device coords(hx,hy) ; hy = screen height - hy
! dot win_window base_x coord = lx
! dot win_window base_y coord = hy
! dot win_window size_x size = hx - lx + 1
! dot win_window size_y size = ly - hy + 1
! rect win_window base_x coord = lx
! rect win_window base_y coord = ly + 1 - gap
! rect win_window size_x size = hx - lx + 1
! p1_x coord = lx
! !
! ! draw vertical lines
! !
! lx = hx1 ; ly = hy1
! map to device coords(lx,ly)
! y1 = screen height - ly
! lx = lx1 ; ly = ly1
! map to device coords(lx,ly)
! y = screen height - ly
! lx = lx1 ; ly = ly1
! %while lx <= hx1 %cycle
! hx = lx ; hy = ly
! map to device coords(hx,hy)
! x = hx
! gpr move(x,y,status)
! gpr line(x,y1,status)
! lx = lx + gap
! %repeat
! x = 0 ; x1 = 0
! %for i = 0, 1, Max Plane Num %cycle
! x = i
! gpr set raster op(x,x1,status)
! %repeat
! !
! ! put black boxes on top
! !
! lx = lx1 ; ly = ly1
! %while ly < hy1 %cycle
! hy = ly ; lx = lx1
! map to device coords(lx,hy) ; lx = lx1
! hx = ly + gap
! map to device coords(lx,hx)
! rect win_window size_y size = hx - hy - 1
! p1_y coord = screen height - hx + 1
!! gpr bit blt(display desc,rect win,x { = 0},p1,x { = 0},status)
! gpr pixel blt(display desc,rect win,p1,status)
! abort %if status # ok
! ly = ly + gap
! %repeat
!
! !
! ! put the old values in again
! !
! %for i = 0,1,max plane num %cycle
! x = i
! gpr set raster op(x,rasters(i),status)
! %repeat
! gpr set clip window(clip win,status)
! abort %if status # ok
!%end
const byte array Button Map ('a':'c') = 4, 1, 2
own record (gpr position t) cursor = 0
own short From TTGET = 0
external routine BC alias "EDWIN___C_REQ" ( integername Char, X, Y )
byte c = 0
integer i
routine abort
integer Dummy
gpr release display(Dummy) { Just in case it was claimed }
Printstring ("Request Device fails : ".sysmess(status) )
newline
stop
end
!
! move cursor into window, let cursor be seen,
! wait for a keystroke, switch cursor off again
! and try to return cursor from whence it came !
!
start again:
if Redraw Flag = 1 start
if Refresh Flag = 1 start
User Refresh
else
Deal With Possible Resize
finish
Refresh Flag = 0
Redraw Flag = 0
finish
update dd ;! flush outputs
gpr move(cursor_x coord,cursor_y coord,status)
abort if status # ok
gpr set cursor position(cursor,status)
abort if status # ok
gpr enable input (gpr locator {stop}, mouse keyset(1), status)
abort if status # ok
gpr enable input (gpr keystroke, keyset(1), status)
abort if status # ok
gpr enable input (gpr buttons, mouse keyset(1), status)
abort if status # ok
gpr set cursor active(true,status)
try again :
Char = 0
cycle
obscured = gpr event wait (event type, c, cursor,status)
if event type = gpr entered window start
gpr set cursor active(false,status)
Deal With Possible Resize
-> Give Result if From TTGET = True
-> Start again
finish
gpr set cursor position(cursor,status)
abort if status # ok
repeat until event type = gpr keystroke or event type = gpr buttons
gpr disable input(gpr locator, status)
abort if status # ok
if event type=Gpr buttons start
! at this time we are not interested in the up stroke of the mouse
char = 0 and -> try again if From TTGET = True or not ('a'<=c<='c')
char = Button map (c)
else
! select output(0)
! print string("Keystroke event gives ".itos(c,0)." '".tostring(c)."'".snl)
char = c
if char = 150 then char = cr else if char = 149 then char = bs
finish
Give result:
gpr set cursor active(false,status)
abort if status # ok
x = cursor_x coord
y = screen height - cursor_y coord
end
external routine BSAM alias "EDWIN___C_SAM" ( integername Char, X, Y )
byte c
integer i
short integer array raster ops (0:7)
record(gpr position t) cursor origin
integer cursor active
record(gpr position t) starting pos = cursor
routine abort
integer Dummy
gpr release display(Dummy) { Just in case it was claimed }
Printstring ("Sample Device fails : ".sysmess(status) )
newline
stop
end
!
! move cursor into window, let cursor be seen,
! wait for an event, switch cursor off again
! and try to return cursor from whence it came !
!
if Redraw Flag = 1 start
if Refresh Flag = 1 start
User Refresh
else
Deal With Possible Resize
finish
Refresh Flag = 0
Redraw Flag = 0
finish
update dd ;! flush outputs
gpr move(cursor_x coord,cursor_y coord,status)
abort if status # ok
gpr set cursor position(cursor,status)
abort if status # ok
gpr set cursor active(true,status)
gpr enable input (gpr locator {stop}, mouse keyset(1), status)
abort if status # ok
gpr enable input (gpr keystroke, keyset(1), status)
abort if status # ok
gpr enable input (gpr buttons, mouse keyset(1), status)
abort if status # ok
!
! wait for a first event and then get through all the rest without waiting
! using get cond event wait
!
char = 0
do again :
obscured = gpr event wait (event type, c, cursor,status)
gpr set cursor position(cursor,status)
if event type = gpr entered window start
gpr set cursor active(false,status)
Deal With Possible Resize
-> Give Result
finish
if event type = gpr locator start
cycle
obscured = gpr cond event wait (event type, c, cursor,status)
gpr set cursor position(cursor,status)
if event type = gpr entered window start
gpr set cursor active(false,status)
Deal With Possible Resize
-> Give Result
finish
repeat until event type # gpr locator
finish
! select output(0)
if event type=Gpr buttons start
if 'a' <= c <= 'c' then -
char = Button map (c) else char = 0
! print string("event type is buttons ".itos(cursor_x coord,0).-
! itos(cursor_y coord,4))
else if event type = gpr keystroke
char = c
if char = 150 then char = cr else if char = 149 then char = bs
! print string("event type is keystroke ".itos(cursor_x coord,0).-
! itos(cursor_y coord,4))
! %else %if event type = gpr locator
! printstring("event type is locator ".itos(cursor_x coord,0).-
! itos(cursor_y coord,4))
else
gpr inq cursor(i,raster ops(0),cursor active,cursor,cursor origin,status)
abort if status # ok
! printstring("Didn't recognise the event type ".itos(cursor_x coord,0).-
! itos(cursor_y coord,4)." Active = ".itos(cursor active,0))
if starting pos_x coord = cursor_x coord and -
starting pos_y coord = cursor_y coord start
! newline
-> do again ;! if nothing is happening don't do anything
finish
finish
gpr set cursor position(cursor,status)
abort if status # ok
gpr disable input(gpr locator, status)
abort if status # ok
Give result:
gpr set cursor active(false,status)
abort if status # ok
x = cursor_x coord
y = screen height - cursor_y coord
end
external integer function B TT GET alias "EDWIN_SCREEN_TTGET"
integer C, X, Y
From TTGET = True
BC (C, X, Y)
From TTGET = False
result = C
end
external integer function B Screen Height alias "EDWIN_SCREEN_HEIGHT"
own short width, height, len, window no
own short array list (0:11)
own integer array Null (0:255)
if Translate ("TERM") -> ("apollo") start
pad inq Font (one, width, height, null(0), zero, len, status)
result = 24 if Status # 0
Pad inq Window (one, list, one, window no, status)
result = 24 if Status # 0
result = 5 if List (3) < 5
result = List (3)
finish
result = 24
end
end of file