┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┓
┃                                                    Block Directory of                                                    ┃
┃                                         Filename: 'l1pmods001' type 'compass  e'                                         ┃
┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┛
#Ord Block Name      Words #Blks  Blk#  POut --- Last Edit --- (---block inf word---)
                      Used 
   0 01-a *directory     0     0     0     0 2025/04/08. 04:50 (00321040462000000000) 
   1 01-b bu            58     1     1     1 1990/10/26. 08:29 (47106551035001072001) 
   2 01-c mod files    128     1     2     1 2025/04/22. 07:49 (47321130761001200002) 
   3 01-d dummy          2     0     3     1 2025/04/01. 11:41 (40321005351000002003) 
   4 01-e l1p work      99     1    12     1 2025/05/06. 01:04 (47321230104001143014) 
   5 01-f style graf   233     1    44     1 2025/04/18. 01:04 (47321110104001351054) 
   6 01-g style graf   193     1    45     1 2025/04/18. 01:09 (47321110111001301055) 
   7 02-a style text   162     1    46     1 2025/04/18. 01:15 (47321110117001242056) 
   8 02-b image        288     1    47     1 2025/04/18. 01:42 (47321110152001440057) 
   9 02-c tbtcap       244     0    53     0 2025/05/08. 08:20 (00321241024000364065) 
  10 02-d tbtcap       151     0    54     0 2025/05/03. 09:27 (00321215133000227066) 
  11 02-e tbtcap       178     0    63     0 2025/05/03. 09:09 (00321215111000262077) 
  12 02-f tbtcap       199     0    62     0 2025/05/03. 22:21 (00321216625000307076) 
  13 02-g tbtcap       231     0    67     0 2025/05/03. 09:37 (00321215145000347103) 
  14 03-a format        99     0     4     0 2025/05/02. 08:49 (00321211061000143004) 
  15 03-b format       278     0     5     0 2025/04/29. 08:10 (00321165012000426005) 
  16 03-c format       126     0     6     0 2025/04/29. 08:13 (00321165015000176006) 
  17 03-d format       260     0    13     0 2025/04/29. 08:18 (00321165022000404015) 
  18 03-e format       192     0    51     0 2025/04/22. 10:55 (00321131267000300063) 
  19 03-f format       175     0    41     0 2025/04/22. 13:33 (00321131541000257051) 
  20 03-g format        83     0    48     0 2025/04/22. 13:35 (00321131543000123060) 
  21 04-a format       248     0    28     0 2025/04/22. 13:37 (00321131545000370034) 
  22 04-b format       126     0    15     0 2025/04/09. 00:24 (00321044030000176017) 
  23 04-c format       293     0     7     0 2025/04/03. 08:14 (00321015016000445007) 
  24 04-d format        62     0     8     0 2025/04/19. 13:09 (00321115511000076010) 
  25 04-e format       163     0    42     0 2025/04/12. 13:16 (00321061520000243052) 
  26 04-f format       188     0    10     0 2025/04/05. 16:03 (00321026003000274012) 
  27 04-g format       267     0    11     0 2025/04/20. 08:59 (00321121073000413013) 
  28 05-a format       161     0    50     0 2025/04/20. 10:54 (00321121266000241062) 
  29 05-b box          178     0     9     0 2025/04/06. 17:51 (00321032163000262011) 
  30 05-c savedxxx      73     1    20     1 2025/04/07. 10:02 (47321035202001111024) 
  31 05-d stycommon     45     0    23     0 2025/04/22. 13:45 (00321131555000055027) 
  32 05-e style-cond   285     0    27     0 2025/04/08. 14:06 (00321041606000435033) 
  33 05-f style-cond   259     0    14     0 2025/04/08. 13:05 (00321041505000403016) 
  34 05-g style-cond   289     0    16     0 2025/04/06. 15:46 (00321031756000441020) 
  35 06-a style-cond   291     0    17     0 2025/04/08. 07:53 (00321040765000443021) 
  36 06-b style-cond   236     0    18     0 2025/04/06. 15:43 (00321031753000354022) 
  37 06-c style-cond   107     0    19     0 2025/04/08. 09:23 (00321041127000153023) 
  38 06-d style-exec   176     0    21     0 2025/04/22. 13:52 (00321131564000260025) 
  39 06-e style-exec    94     0    22     0 2025/04/12. 13:19 (00321061523000136026) 
  40 06-f style-exec   176     0    43     0 2025/04/20. 15:01 (00321121701000260053) 
  41 06-g style-exec   254     0    24     0 2025/05/01. 09:09 (00321205111000376030) 
  42 07-a style-exec   275     0    25     0 2025/04/06. 23:43 (00321032753000423031) 
  43 07-b style-exec   235     0    26     0 2025/04/07. 17:26 (00321036132000353032) 
  44 07-c image-cond   239     0    29     0 2025/04/28. 11:46 (00321161356000357035) 
  45 07-d image-cond   269     0    31     0 2025/04/10. 13:40 (00321051550000415037) 
  46 07-e image-cond   254     0    32     0 2025/04/10. 03:59 (00321050373000376040) 
  47 07-f image-exec   228     0    30     0 2025/04/20. 09:05 (00321121105000344036) 
  48 07-g image-exec   150     0    33     0 2025/04/22. 14:00 (00321131600000226041) 
  49 08-a image-exec   263     0    35     0 2025/04/30. 19:56 (00321172370000407043) 
  50 08-b image-exec   269     0    36     0 2025/04/11. 10:02 (00321055202000415044) 
  51 08-c image-exec   209     0    37     0 2025/04/10. 08:13 (00321051015000321045) 
  52 08-d image-exec   232     0    38     0 2025/04/22. 14:07 (00321131607000350046) 
  53 08-e image-exec   236     0    39     0 2025/04/10. 09:11 (00321051113000354047) 
  54 08-f image-exec   153     0    40     0 2025/04/22. 14:08 (00321131610000231050) 
  55 08-g terms         39     0    49     0 2025/04/19. 22:30 (00321116636000047061) 
  56 09-a window       143     0    52     0 2025/05/08. 15:34 (00321241742000217064) 
  57 09-b wide-fram    248     0    34     0 2025/05/09. 09:17 (00321245121000370042) 
  58 09-c wide-tbw19   153     0    56     0 2025/05/09. 00:18 (00321244022000231070) 
  59 09-d wide-exec1    27     0    55     0 2025/04/27. 18:24 (00321156230000033067) 
  60 09-e w-simplt      57     0    61     1 2025/05/04. 08:42 (40321221052000071075) 
  61 09-f at cmd        58     0    57     0 2025/04/27. 21:22 (00321156526000072071) 
  62 09-g -draw-s      211     0    58     0 2025/05/02. 00:33 (00321210041000323072) 
  63 10-a -fine-       239     0    59     0 2025/04/29. 16:19 (00321166023000357073) 
  64 10-b lin(r)it      41     0    64     0 2025/05/09. 15:07 (00321245707000051100) 
  65 10-c pix touch    301     0    60     0 2025/05/09. 09:26 (00321245132000455074) 
  66 10-d                0     0    68     0 1973/00/00. 00:00 (00000000000000000104) 
  67 10-e                0     0    69     0 1973/00/00. 00:00 (00000000000000000105) 
  68 10-f                0     0    70     0 1973/00/00. 00:00 (00000000000000000106) 
  69 10-g                0     0    71     0 1973/00/00. 00:00 (00000000000000000107) 
  70 11-a                0     0    72     0 1973/00/00. 00:00 (00000000000000000110) 
  71 11-b                0     0    73     0 1973/00/00. 00:00 (00000000000000000111) 
  72 11-c                0     0    74     0 1973/00/00. 00:00 (00000000000000000112) 
  73 11-d                0     0    75     0 1973/00/00. 00:00 (00000000000000000113) 
  74 11-e                0     0    76     0 1973/00/00. 00:00 (00000000000000000114) 
  75 11-f                0     0    77     0 1973/00/00. 00:00 (00000000000000000115) 
  76 11-g                0     0    78     0 1973/00/00. 00:00 (00000000000000000116) 
  77 12-a                0     0    79     0 1973/00/00. 00:00 (00000000000000000117) 
  78 12-b                0     0    80     0 1973/00/00. 00:00 (00000000000000000120) 
  79 12-c                0     0    81     0 1973/00/00. 00:00 (00000000000000000121) 
  80 12-d                0     0    82     0 1973/00/00. 00:00 (00000000000000000122) 
  81 12-e                0     0    83     0 1973/00/00. 00:00 (00000000000000000123) 
  82 12-f                0     0    84     0 1973/00/00. 00:00 (00000000000000000124) 
  83 12-g                0     0    85     0 1973/00/00. 00:00 (00000000000000000125) 
  84 13-a                0     0    86     0 1973/00/00. 00:00 (00000000000000000126) 
  85 13-b                0     0    87     0 1973/00/00. 00:00 (00000000000000000127) 
  86 13-c                0     0    88     0 1973/00/00. 00:00 (00000000000000000130) 
  87 13-d                0     0    89     0 1973/00/00. 00:00 (00000000000000000131) 
  88 13-e                0     0    90     0 1973/00/00. 00:00 (00000000000000000132) 
  89 13-f                0     0    91     0 1973/00/00. 00:00 (00000000000000000133) 
  90 13-g                0     0    92     0 1973/00/00. 00:00 (00000000000000000134) 
  91 14-a                0     0    93     0 1973/00/00. 00:00 (00000000000000000135) 
  92 14-b                0     0    94     0 1973/00/00. 00:00 (00000000000000000136) 
  93 14-c                0     0    95     0 1973/00/00. 00:00 (00000000000000000137) 
  94 14-d                0     0    96     0 1973/00/00. 00:00 (00000000000000000140) 
  95 14-e                0     0    97     0 1973/00/00. 00:00 (00000000000000000141) 
  96 14-f                0     0    98     0 1973/00/00. 00:00 (00000000000000000142) 
  97 14-g                0     0    99     0 1973/00/00. 00:00 (00000000000000000143) 
  98 15-a                0     0   100     0 1973/00/00. 00:00 (00000000000000000144) 
  99 15-b                0     0   101     0 1973/00/00. 00:00 (00000000000000000145) 
 100 15-c                0     0   102     0 1973/00/00. 00:00 (00000000000000000146) 
 101 15-d                0     0   103     0 1973/00/00. 00:00 (00000000000000000147) 
 102 15-e                0     0   104     0 1973/00/00. 00:00 (00000000000000000150) 
 103 15-f                0     0   105     0 1973/00/00. 00:00 (00000000000000000151) 
 104 15-g                0     0   106     0 1973/00/00. 00:00 (00000000000000000152) 
 105 16-a                0     0   107     0 1973/00/00. 00:00 (00000000000000000153) 
 106 16-b                0     0   108     0 1973/00/00. 00:00 (00000000000000000154) 
 107 16-c                0     0   109     0 1973/00/00. 00:00 (00000000000000000155) 
 108 16-d                0     0   110     0 1973/00/00. 00:00 (00000000000000000156) 
 109 16-e                0     0   111     0 1973/00/00. 00:00 (00000000000000000157) 
 110 16-f                0     0   112     0 1973/00/00. 00:00 (00000000000000000160) 
 111 16-g                0     0   113     0 1973/00/00. 00:00 (00000000000000000161) 
 112 17-a                0     0   114     0 1973/00/00. 00:00 (00000000000000000162) 
 113 17-b                0     0   115     0 1973/00/00. 00:00 (00000000000000000163) 
 114 17-c                0     0   116     0 1973/00/00. 00:00 (00000000000000000164) 
 115 17-d                0     0   117     0 1973/00/00. 00:00 (00000000000000000165) 
 116 17-e                0     0   118     0 1973/00/00. 00:00 (00000000000000000166) 
 117 17-f                0     0   119     0 1973/00/00. 00:00 (00000000000000000167) 
 118 17-g                0     0   120     0 1973/00/00. 00:00 (00000000000000000170) 
 119 18-a                0     0   121     0 1973/00/00. 00:00 (00000000000000000171) 
 120 18-b                0     0   122     0 1973/00/00. 00:00 (00000000000000000172) 
 121 18-c                0     0   123     0 1973/00/00. 00:00 (00000000000000000173) 
 122 18-d                0     0   124     0 1973/00/00. 00:00 (00000000000000000174) 
 123 18-e                0     0   125     0 1973/00/00. 00:00 (00000000000000000175) 
 124 18-f                0     0    65     0 1973/00/00. 00:00 (00000000000000000101) 
 125 18-g                0     0    66     0 1973/00/00. 00:00 (00000000000000000102) 

File Name -------- l1pmods001
File Type -------- compass  
Account ---------- s0sup
Update Level ----- 0
Created ----------  05/09/25
Last Edited ------  05/09/25
                    15.07.11.
       by -------- sinder::::::::b
       of -------- s
       at -------- 4-0
Change Code ------ group s
Inspect Code ----- account system
File Access Code - no match permitted
System Access ---- allowed
Submit Block ----- 
Charset Lesson --- 
Charset Block ---- 
Micro Lesson ----- 
Micro Block ------ 
Processor -------- 
Editor ----------- 
Author Name ------ 'dale 'sinder
Author Dept. ----- 
Author Phone ----- 217-778-0680
Subject ---------- l1p mods
Audience --------- system staff
Description ------ 'modsets specific to 'level 1 'protocol ('portal/'plato'access)

* /---   block=01-b bu                   1990/10/26. 08:29    text  out
*
*
*        this weeks ident prefix is the name of this block
*
*        previous weeks mods are kept in ',oplmods',
*
*        previous previous weeks mods are kept in ',ooplmods',
*
*         'n'o't'e'; there 'm'u's't be at least 'o'n'e modset here,
*         even if its nothing more than ',*ident   dummy',
*
*         'n'o't'e'; this must be the 'f'i'r's't block in this file.
*         =source= expects to find the current ident prefix
*         as the name of the first block here.
*
* /---   block=01-c mod files            2025/04/22. 07:49    text  out
*list     parts
 
'the standard assembly/listing procedures expect all
modsfiles, including personal files, to be on 'p'l'a't'o
'master 'file ',modsmf',, which resides on pack 'p'd'e'v1. (10/2/85)
 
 
'the regular modset files are';
 
*plmods*  - modsets used in all assemblies and applied
            permanently to *platopl* each week.
            *oplmods* has previous mod sets..
            *ooplmods* has even older mod sets...
 
*tpmods*  - modsets used in all assemblies, but never
            applied permanently to *platopl*.
 
*gogomods*- modsets used in all assemblies, except the code-
            sharing full assemblies, and not applied 
            permanently to *platopl*.  the modsets in this
            file are active during gogo only; they are
            partialed out before the codesharing assemblies
            are run.  the programmers must reactivate their
            modsets each week after codesharing is finished.
 
*l1pmods* - modsets used in all assemblies, but never
            applied permanently to *platopl*.
            these add level protocol enhancements
* /---   block=01-d dummy                2025/04/01. 11:41    source  out
*ident    tdummy2
* /---   block=01-e l1p work             2025/05/06. 01:04    text  out
'these commands/features have been implemented for 'l1'p
 
circle    rad                drs 20250404
circle    rad,start,end      drs 20250405
box                          drs 20250406
gbox                         drs 20250406
style     graphics           drs 20250409
style     text               drs 20250409
image                        drs 20250411
window                       drs 20250422
wide screen                  drs 20250430
 
 
'undone areas';
 
pixel res pointing
stretch   used for graphics editing assist
local x   dealing with local files
trap      saving and replaying raw protocal data
          possibly translated by a offest
          or ',attached', to the mouse
texted    terminal support for wysiwyg editor
local i/0
kermit
 
 
------------ saves and notes -------------------------
 sysclok
* /---   block=01-f style graf           2025/04/18. 01:04    text  out
                                 'n'o't'e';  'this command works
  style   graphics               only at terminals with a
                                 'plato'access 'program.
 
      style   graphics;option,normal;thickness,var;...
      style   graphics;option,fill;pattern,var;...
      style   graphics;dash,var;thickness,var
      style   graphics;clear
 
 'the -style   graphics- commands affect certain display
 commands, adding a thickness or pattern or dashed lines
 to graphic displays.  'the available tags are';
 
    clear          $$ clears the graphics styles in effect
    thickness,var  $$ sets the thickness for objects
    pattern,var    $$ sets the pattern for thick objects
                         and filled objects
    dash,var       $$ sets the dash style for lines
    option,normal  $$ normal objects
    option,fill    $$ filled objects (disables thickness)
 
 'styles are merged when new -style- commands are executed.
 
 'the style settings are cleared at a full screen erase
 or when -style  graphics;clear- is executed.
 
 
 'for patterns, the variable in the tag may range from 0
 to 31, indicating which of the 32 patterns is to be used.
 'the default is 1 (a solid foreground color).
 
 'for patterns other than 1, the terminal must be in mode
 rewrite for the -style- command to work.
 
 'for the ',dash', tag, the variable may range from 0 to 7,
 indicating the type of dash to be used.  'the default is
 0 (a solid line).  'this tag does not affect circles or
 boxes.
 
 'thicknesses should be odd values, rather than even.  'note
 that the thickness of boxes drawn with -box- is not affected
 by a ',thickness', tag of a -style- command.  'this is because
 the thickness tag on the -box- command itself, even the
 default of 1, overrides the thickness specified by the
 -style- command.  'use a third tag for -box- to control
 thickness of boxes.  'if the tags for thickness are not
 integers, they will be rounded to the nearest integer.
 
 'the -color- command can be used with the
 -style- command for very effective graphics.
* /---   block=01-g style graf           2025/04/18. 01:09    text  out
 
'when some graphics styles are in effect, the terminal does
not plot lines as soon as they are received.  'this is done
so that the object drawn can be made to look as good as
possible.  'consider, for example, a series of connected
thick line segments.  'in order to form a smooth joint, the
terminal must know the angle formed between two line
segments before it draws the segments.  'similar situations
arise with dashed lines or with lines drawn with the ',fill',
option set.  'when the terminal receives such line-drawing
information, it stores the information in a ',polyline
buffer',.  'lines are not drawn until the terminal
receives a signal that the line-drawn object is complete.
'the terminal uses the following signals for complete
',polyline buffers',';
 
*  an -at- command or a ',skip', in a draw
*  a -style graphics- command
*  a -color- or -palette- command
*  a change or reset in type of data sent to the terminal
        ( for example a -write- or -dot- command )
 
'in this example, the line is not drawn until after the
user has pressed 'n'e'x't at the -pause-.
 
unit    draw
style   graphics;thickness,3
at      1010
write   'hi there.
draw    ;1010
pause   keys=next
at      1210
write   'what is your name'/
 
'the second -at- command above serves as the signal that
the line is complete.  'the line is not drawn until after
this -at- is executed.
 
'to plot the line before the -pause-, insert
-style  graphics;clear- after -draw- and before -pause-';
unit    draw
style   graphics;thickness,3
at      1010
write   'hi there.
draw    ;1010
style   graphics;clear
pause   keys=next
at      1210
write   'what is your name'/
* /---   block=02-a style text           2025/04/18. 01:15    text  out
                                  'n'o't'e';  'this command works
   style   text                   only at terminals with a
                                  'plato'access 'program.
 
       style   text;option 1;option 2; ...
       style   text;hthick;italic;underline;strikeout
       style   text;vthick;underline1;strikeout1;shadow
       style   text;clear
 
'the -style   text- command affects the plotting of size 0
and other non line-drawn text when viewed with 'plato'access
software.  'it adds certain stylistic effects to characters
before plotting them.
'the possible options are these';
hthick        doubles horizontal thickness of the character
vthick        doubles vertical thickness of the character
italic        writes in an italic-like slant
underline     underlines most* characters
underline1    underlines all characters
strikeout     draws a horizontal line through most* characters
strikeout1    draws a horizontal line through all characters
shadow        applies a checkerboard mask to characters
invert        reverses each on/off dot before plotting
clear         clears all style settings
 
'the text style is cleared on a full screen erase.  'this
command does not affect writing in sizes other than 0.
 
*'characters not affected by ',underline', and ',strikeout', are
(space)  '.  ,  .  ';  ;  '/  '7  ',  'i  tilde  umlaut  hacek
acute accent  grave accent  cedilla  ('all 'a's'c'i'i 'm3 chars)
* /---   block=02-b image                2025/04/18. 01:42    text  out
                              'n'o't'e';  'this command works
  -image-                     only on 'plato'access terminals
 
 
image   save;x1,y1;x2,y2;destination;format
image   get;sx1,sy1;sx2,sy2;dx1,dy1;dx2,dy2;source;palette
image   copy;x1,y1;x2,y2;dx1,dy1;dx2,dy2
image   delete;destination
 
'the -image- command may be used to save any portion of the
screen as a bitmap and to place a rectangular region from a
saved bitmap onto the screen at any location.  'when plotting
a bitmap on the screen, the source bitmap is scaled to fit
into the destination rectangle if necessary.
 
image   save;x1,y1;x2,y2;destination;format
 
'saves the rectangular region whose opposite corners are
(x1,y1) and (x2,y2) to ',destination', in the specified
format.
',format', is an expression specifying the internal format
wished for the saved bitmap.
'currently, 0 and 1 are valid values';
        0 = 'local format. 'supported in all 'portals.
        1 = 'p'c'x format. (not guaranteed)
 
image   get;sx1,sy1;sx2,sy2;dx1,dy1;dx2,dy2;source;palette
 
'plots the rectangular subset of ',source', enclosed by
(sx1,sy1) and (sx2,sy2) onto the rectangular screen area
enclosed by  (dx1,dy1) and (dx2,dy2).
'note that the rectangular subset of ',source', is in the
coordinate system of the ',source', bitmap, with the
origin in the lower-left hand corner of the bitmap.
 
',palette', should always be 0.
 
',destination', and ',source', are in the form';
          mem';,slot number
example';
          mem';,5
 
 
 'using 'memory 'spot 'i'd number to 'identify 'image
 
 'the image can be identified by 'i'd number which
 points to the memory spot in which the image is
 stored.  'i'd numbers are normally between 0 and
 254.  'i'd numbers greater than 250 are reserved for
 system use.
 
 'for example';
 
         image   save;x1,y1;x2,y2;mem';,1;0
 
 saves the image in memory slot ^$1.
 
 'using -1 with an -image delete- will delete all
 images and thereby free all memory used by all bitmaps.
 
 'to do this, use';
 
         image   delete;mem';,-1
 
image   copy;x1,y1;x2,y2;dx1,dy1;dx2,dy2
 
'copies the region of the screen specified by the first
two points to the region specified by the second two
points.  'the copy is scaled to fit the destination region
if necessary.
 
image   delete;destination
 
'deletes the bitmap specified by ',destination', and releases
any memory associated with it (where applicable).
 
* /---   block=02-c tbtcap               2025/05/08. 08:20    source 
*/ --------------------------------------------------------
*/ add a terminal capabilities word to student bank
*/ --------------------------------------------------------
*ident     tbtcap  drs.           23/11/08.
*deck platxt
*i platxt.1262
 tbtcap   bss    1           terminal capabilites
 cp.fill  equ    0           fill bit - least sig. bit
 cp.pal   equ    1           palette
 cp.styl  equ    2           styles
 cp.ftou  equ    3           fine touch
 cp.kerm  equ    4           kermit
 cp.trap  equ    5           trap/stretch
 cp.dsty  equ    6           define styles
 cp.lexe  equ    7           local exec
 cp.xor   equ    8           xor mode
 cp.img   equ    9           image
 cp.inhb  equ    10          terminal inhibit/allow
 cp.txt1  equ    11          terminal text edit 1
 cp.aud   equ    12          basic audio fucntions
 cp.tprt  equ    13          text screen print bit
*
*   bits 48 - 53 operating system id
*
 cp.osid  equ    48
 cp.oswi  equ    6
*
 cp.pixt  equ    57          pixel touch on bit
 cp.chrd  equ    58          fill chord flag
 cp.filf  equ    59          fill flag  - most sig bit
*edit platxt
*/ end platxt
*deck lex1
*i lex1.795
          sysnam tbtcap
*i lex1.680
          sysnam terscrn,terscrn
*/ end lex1
*deck pftext
*i zhboy.2
 terscrn  data   10001000100010000000b
*
*         12/ plato x screen size
*         12/ plato y screen size
*         12/ terminal x screen size
*         12/ terminal y screen size
*          4/ reserved for protocol level flags
*          1/ ascii plato iv bit (no mode 4)
*          4/ mtutor version number
*          1/ cdc epap bit
*          1/ protocol level 1 flag
*          1/ color flag
*
 exal1    equ    58          level 1 ascii flag
*
 asciv    equ    52          ascii plato iv bit
*
 xtouchw  data   0           extended touch word
*
*         3/ state of input index 0..7
*         15/
*         6/ cursor bits, lower is touch
*         18/ x pointer loc
*         18/ y pointer loc
*
*
*
*edit pftext
*/ end pftext
* /---   block=02-d tbtcap               2025/05/03. 09:27    source 
*deck lexdef
*i lexdef.142
          sym    ztlevel,70,95,icmpnam,sname7,ztlevel,s
          sym    ztosid,70,95,icmpnam,sname6,ztosid,s
          sym    ztxpps,70,95,icmpnam,sname6,ztxpps,s
          sym    ztypps,70,95,icmpnam,sname6,ztypps,s
          sym    ztxppc,70,95,icmpnam,sname6,ztxppc,s
          sym    ztyppc,70,95,icmpnam,sname6,ztyppc,s
          sym    zxmax,70,95,icmpnam,sname5,zxmax,s
          sym    zymax,70,95,icmpnam,sname5,zymax,s
          sym    zymin,70,95,icmpnam,sname5,zxymin,s
          sym    zxmin,70,95,icmpnam,sname5,zxymin,s
          sym    zclicks,70,95,icmpnam,sname7,zclicks,s
          sym    ztfill,70,95,icmpnam,sname6,ttfill,s
          sym    ztgstyl,70,95,icmpnam,sname7,ttgstyl,s
          sym    ztftouc,70,95,icmpnam,sname7,ttftouc,s
          sym    ztkermt,70,95,icmpnam,sname7,ttkermt,s
          sym    zttrap,70,95,icmpnam,sname6,tttrap,s
          sym    ztdstyl,70,95,icmpnam,sname7,ttdstyl,s
          sym    ztlexec,70,95,icmpnam,sname7,ttlexec,s
          sym    ztmxor,70,95,icmpnam,sname6,ttmxor,s
          sym    ztimage,70,95,icmpnam,sname7,ttimage,s
          sym    ztinhib,70,95,icmpnam,sname7,ttinhib,s
          sym    zttxt1,70,95,icmpnam,sname6,tttxt1,s
          sym    ztaud,70,95,icmpnam,sname5,ttaud,s
          sym    zttprt,70,95,icmpnam,sname6,tttprt,s
 
*edit lexdef
* /---   block=02-e tbtcap               2025/05/03. 09:09    source 
*/ end lexdef
*deck getvar
*i getvar.49
          entry  ztlevel
          entry  ztosid
          entry  ztxpps,ztypps,zxmax,zymax,txmax
          entry  ztxppc,ztyppc,zxymin,zclicks
*i getvar.1988
 ztlevel  ps                 protocol level of the station
          sa1    terscrn
          mx2    -1
          lx1    -1
          bx1    -x2*x1
          eq     ztlevel
*
 ztosid   ps                 terminal environment
          rj     ztlevel
          zr     x1,ztosx
          sa1    tbtcap
          mx2    -cp.oswi
          lx1    -cp.osid
          bx1    -x2*x1
          sx1    x1+1
          eq     ztosid
 ztosx    sx1    0
          eq     ztosid
*
 ztxpps   ps                 terminal max width
          sa1    terscrn
          mx2    -12
          lx1    -24
          bx1    -x2*x1
          eq     ztxpps
*
 ztypps   ps                 terminal max high - 512
          sa1    terscrn
          mx2    -12
          lx1    -12
          bx1    -x2*x1
          eq     ztypps
*
 zclicks  ps
          rj     ztlevel
          zr     x1,noclick    not l1p
          sa1    key
          lx1    -8
          mx2    -2
          bx1    -x2*x1
          sx1    x1-1
          nz     x1,noclick    not a touch key
          sa1    xtouchw
          lx1    -36
          mx2    -2
          bx1    -x2*x1
          eq     zclicks
*
 noclick  bss    0
          sx1    -1
          eq     zclicks
* /---   block=02-f tbtcap               2025/05/03. 22:21    source 
 zxmax    ps                 current operating max x
          sa1    terscrn
          mx2    -12
          lx1    -48
          bx1    -x2*x1
          sx1    x1-1
          eq     zxmax
*
 zymax    ps                 current  operating max y - 511
          sa1    terscrn
          mx2    -12
          lx1    -36
          bx1    -x2*x1
          sx1    x1-1
          eq     zymax
*
 txmax    ps                 current operating max + 1
          sa1    terscrn
          mx0    -12
          lx1    -48
          bx1    -x0*x1
          eq     txmax
*
*
 ztxppc   ps                 char width in pixels
          sx1    8
          eq     ztxppc
*
 ztyppc   ps                 char height in pixels
          sx1    16
          eq     ztyppc
*
 zxymin   ps                 min x and t - always 0
          sx1    0
          eq     zxymin
*
          entry  ttimage
 ttimage  eq     *           image command support
          call   ttcap,59-cp.img
          eq     ttimage
*
          entry  ttinhib
 ttinhib  eq     *           local inhibit/allow command support
          call   ttcap,59-cp.inhb
          eq     ttinhib
*
          entry  tttxt1
 tttxt1   eq     *           local text edit assistance 1
          call   ttcap,59-cp.txt1
          eq     tttxt1
*
          entry  ttaud
 ttaud    eq     *           basic audio functions
          call   ttcap,59-cp.aud
          eq     ttaud
*
*
          entry  tttprt
 tttprt   eq     *           text screen print capability
          call   ttcap,59-cp.tprt
          eq     tttprt
*
* 
* /---   block=02-g tbtcap               2025/05/03. 09:37    source 
*
 ttcap    eq     *
          sa1    tbtcap      get capabilities word
          lx1    b1          bit to top
          mx2    1
          bx1    x2*x1       get bit
          ax1    58          0 or -1
          eq     ttcap
*
          entry  ttfill
 ttfill   eq     *           fill supported flag
          call   ttcap,59-cp.fill
          eq     ttfill
*
*          entry  ttpalet
* ttpalet  eq     *           palette supported flag
*          call   ttcap,cp.pal
*          eq     ttpalet
*
          entry  ttgstyl
 ttgstyl  eq     *           graphics/text styles supported flag
          call   ttcap,59-cp.styl
          eq     ttgstyl
*
          entry  ttftouc
 ttftouc  eq     *           fine touch supported flag
          call   ttcap,59-cp.ftou
          eq     ttftouc
*
          entry  ttkermt
 ttkermt  eq     *           kermit operations supported flag
          call   ttcap,59-cp.kerm
          eq     ttkermt
*
          entry  tttrap
 tttrap   eq     *           terminal trap operations supported flag
          call   ttcap,59-cp.trap
          eq     tttrap
*
          entry  ttdstyl
 ttdstyl  eq     *           terminal defined styles supported flag
          call   ttcap,59-cp.dsty
          eq     ttdstyl
*
          entry  ttlexec
 ttlexec  eq     *           lexec command support
          call   ttcap,59-cp.lexe
          eq     ttlexec
*
          entry  ttmxor
 ttmxor   eq     *           xor mode support
          call   ttcap,59-cp.xor
          eq     ttmxor
          
*/ end getvar
*deck pcftext
*d jbfgt.2
*i pcftext.65
 psyslth  equ    30          station bank length
*edit pcftext
*/ end pcftext
*/
*/        'modify the length of the station bank.
*/
*deck dsn1
*delete dsn1.191
          errnz  stbkl-30d  station bank length .ne. 30d
*/ end dsn
*/
*/ --------------------------------------------------------
*/ end of modset
* /---   block=03-a format               2025/05/02. 08:49    source 
*/ --------------------------------------------------------
*/ add infrastructure for l1p support
*/ includes adding some tables and intercepting 
*/ some calls
*/
*/ add l1p support for circles (round)
*/ add l1p support for arcs (round)
*/ add l1p support for -box-
*/ add l1p support for -style graphics...-
*/ add l1p support for -style text...-
*/ add l1p support for -image-
*/ add l1p support for -window-
*/ --------------------------------------------------------
*ident l1pm001         drs.           25/04/02.
*deck fovlay5
*i fovlay5.1415
          pl     x1,l1pchk   check if level 1
*i fovlay5.1420
*
 l1pchk   sa1    l1pflag
          zr     x1,asciend  not l1p - end proc
*  process l1p output
          sx1    b2-endcode     upper bounds chk
          pl     x1,asciend
          sb2    b2-67b      offset table index
          jp     b2+otabex
*
* /---   block=03-b format               2025/04/29. 08:10    source 
*i fovlay5.1442
*
*         jump table for l1p 
*
 otabex   bss    0
*
 +        eq     nogood      67b
 +        eq     nogood      70b
 +        eq     nogood
 +        eq     nogood
 +        eq     tearc       73b - elliptical arc
 +        eq     tcircl      74b - circle
 +        eq     telip       75b - ellipse
 +        eq     tcarc       76b - carc
 +        eq     tbox        77b - box
 +        eq     nogood      100b
 +        eq     twin        101b - window
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      110b
 +        eq     xtstyl      111b set text style
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      120b
 +        eq     nogood
 +        eq     nogood
 +        eq     txcent      123b - x centering
 +        eq     nogood
 +        eq     setgsty     125b set graphics style
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      130b
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      140b
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     xsavimg     150b  save imagee
 +        eq     xgetimg     151b  get image
 +        eq     xinfimg     152b  image info
 +        eq     xcpyimg     153b  image copy
 +        eq     xclrimg     154b image clear
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      160b
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood      170b
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
 +        eq     tersav      174b - save bottom two lines
 +        eq     terest      175b - restore bottom 2 lines
 +        eq     nogood
 +        eq     nogood
 +        eq     nogood
*
* /---   block=03-c format               2025/04/29. 08:13    source 
*i fovlay5.1468
*
 l1psav1  bssz   1
 l1psav2  bssz   1
*
*         command/mode ascii prefix for l1p
*
 ccircl   cquence esc,f.lq,f.c
 carc     cquence esc,f.lq,f.b
 cbox     cquence esc,f.lq,f.k
 celip    cquence esc,f.lq,f.d
 cearc    cquence esc,f.lq,f.a
 cwind    cquence esc,f.lq,f.lz
*
 cxcent   cquence esc,f.lq,f.lx
*
 ccgsty   cquence esc,f.7
*
*         these must be in this order
*
 gstyles  bss    0
 cthik    cquence esc,f.li,f.b
 cpatt    cquence esc,f.li,f.a
 cdash    cquence esc,f.li,f.d
 cfill    cquence esc,f.li,f.f
 cjoin    cquence esc,f.li,f.e
 ccap     cquence esc,f.li,f.c
*
*         end order important
*
 ctsty    cquence esc,f.li,f.lc
*
 csavimg  cquence esc,f.lj,f.la
 cgetimg  cquence esc,f.lj,f.lcb
 cinfimg  cquence esc,f.lj,f.lc
 ccpyimg  cquence esc,f.lj,f.ld
 cclrimg  cquence esc,f.lj,f.le
 cechimg  cquence esc,f.lj,f.lf
*
*
 clpat    cquence esc,f.li,f.g
 cldas    cquence esc,f.li,f.h
*         
* /---   block=03-d format               2025/04/29. 08:18    source 
*
*         code=74b circle l1p
*
 tcircl   bss    0
*                set the terminal mode'; circle
          unpack ccircl
*                send the radius
          sendata x5
          sx6    36b
          sa6    tmode
          eq     outloop
*         
*         code=78b arc (round) l1p
*
 tcarc    bss    0
*                set the terminal mode'; arc
          unpack carc
*                send the radius
          sendata x5
*
          sa5    a5+1        get next word
          bx6    x5          save
          sa6    l1psav1
          mx2    -18
          bx5    -x2*x5
          sendata x5         start ang * 10
          sa1    l1psav1     restore
          mx2    -18
          ax1    18
          bx5    -x2*x1
          sendata x5         length of arc * 10
*
          sx6    36b
          sa6    tmode
          eq     outloop
*
*
*         code=75b ellipse l1p
*
 telip    bss    0
*                set the terminal mode'; circle
          unpack celip
*                send the x radius
          sendata x5
          sa5    a5+1        get next word
          mx2    -18
          bx5    -x2*x5
          sendata x5        y radius
          sx6    36b
          sa6    tmode
          eq     outloop
*         
*         code=73b arc (ellipse) l1p
*
 tearc    bss    0
*                set the terminal mode'; arc
          unpack cearc
*                send the x radius
          sendata x5
*
          sa5    a5+1        get next word
          mx2    -18
          bx5    -x2*x5
          sendata x5         y radius
*
          sa5    a5+1        get next word
          bx6    x5          save
          sa6    l1psav1
          mx2    -18
          bx5    -x2*x5
          sendata x5         start ang * 10
          sa1    l1psav1     restore
          mx2    -18
          ax1    18
          bx5    -x2*x1
          sendata x5         length of arc * 10
*
          sx6    36b
          sa6    tmode
          eq     outloop
*
 txcent   bss    0
          unpack cxcent
          sendata x5
          eq     outloop
* /---   block=03-e format               2025/04/22. 10:55    source 
*
*         on entry - x5 = 24/, 18/x, 18/y
*                (a5+1) = 6/, 18/thickness, 18/x, 18/y
*
 tbox     bss    0
*                set the terminal mode'; box
          unpack cbox
*                send the first corner
          mx2    -18
          bx4    -x2*x5      y
          ax5    18
          bx3    -x2*x5      x
          sendxy
*                send the second corner
          sa5    a5+1        get next word
          bx6    x5
          sa6    l1psav1
          mx2    -18
          bx4    -x2*x5      y
          ax5    18
          bx3    -x2*x5      x
          sendxy
*                  send the thickness
          sa4    l1psav1     recover intial value
          bx5    x4
          ax5    36
          mx2    -18
          bx5    -x2*x5
          sendata x5         start ang * 10
*
          sx6    36b
          sa6    tmode
          eq     outloop
*
 twin     bss    0
*                window command
          unpack cwind
*                send the first corner
          mx2    -9
          bx3    -x2*x5      x
          ax5    9
          bx4    -x2*x5      y
          bx6    x5
          sa6    l1psav1
          sendxy
*                send the second corner
          sa1    l1psav1
          bx5    x1
          ax5    9
          bx3    -x2*x5      x
          ax5    9
          bx4    -x2*x5      y
          sendxy
          eq     outloop
*
 xtstyl   bss    0           set text style
          unpack ctsty
          sendata x5
          eq     outloop
*
*
* /---   block=03-f format               2025/04/22. 13:33    source 
*
*  this is broken - b4 probably overwritten in sendata
* imoutw   ps
*          sb4    b1          save count
* imoutl   sa5    a5+1
*          sendata x5
*          sb4    b4-1
*          zr     b4,imoutw
*          eq     imoutl
*
*         send next four words of mout
*
 send4    eq     *
          sa5    a5+1
          sendata x5
          sa5    a5+1
          sendata x5
          sa5    a5+1
          sendata x5
          sa5    a5+1
          sendata x5
          eq     send4
*
 xsavimg  bss    0           image save
          unpack csavimg
*          call   imoutw,5
          rj     send4
          sa5    a5+1
          sendata x5
          eq     outloop
*
 xgetimg  bss    0           image get
          unpack cgetimg
*          call   imoutw,9
          rj     send4
          rj     send4
          sa5    a5+1
          sendata x5
          eq     outloop
*
*
 xinfimg  bss    0           image info
          unpack cinfimg
          sa5    a5+1
          sendata x5
          eq     outloop
*
*
 xcpyimg  bss    0           image copy
          unpack ccpyimg
*          call   imoutw,8
          rj     send4
          rj     send4
          eq     outloop
*
*
 xclrimg  bss    0           image delete
          unpack cclrimg
          sa5    a5+1
          sendata x5
          eq     outloop
*
* /---   block=03-g format               2025/04/22. 13:35    source 
*
*         send coords for term save area
*
 set4     eq     *
          sx5    0
          sendata x5
          sx5    0
          sendata x5
          sx5    511
          sendata x5
          sx5    32
          sendata x5
          eq     set4
*
*         save what term'/ area
*
 tersav   bss    0
          unpack csavimg
          rj     set4
          sx5    253+0400b
          sendata x5
          eq     outloop
*
*         restore what term'/ area
*
 terest   bss    0
          unpack cgetimg
          rj     set4
          rj     set4
          sx5    253+0400b
          sendata x5
          eq     outloop
* /---   block=04-a format               2025/04/22. 13:37    source 
*
          title  macro definitions
*
*
*
*         out8
*         output next 8-bit byte (parity already generated)
*
*         destroys - x1
*
*          purgmac out8
* out8     macro  arg
*          local  out890
*          ifc    ne,*arg*x1*,1
*          sx1    arg
*          lx7    8           position output register
*          bx7    x1+x7       attach next byte
*          pl     x7,out890
*          sa7    a7+1        store next completed word
*          mx7    1
*          lx7    60-16       re-set output register
* out890   bss    0
*          endm
*
*
*
*         out8p
*         generate parity and output 8-bit byte
*
*         destroys - x0,x1
*
          purgmac out8p
 out8p    macro  arg
          ifc    ne,*arg*x1*,1
          sx1    arg
          cx0    x1          determine even/odd number bits
          lx0    59
+         pl     x0,*+1      jump if even number of bits
          sx1    x1+200b     generate even parity
          pack8  x1
          endm
*
*
*         setgsty
*
*         set graphics style
*
*         on entry -- x5 = 24/, 18/data, 18/style index
*
*         style index--
*                0 = clear graphics styles
*                1 = set thickness
*                2 = set pattern
*                3 = set dash
*                4 = set option
*                5 = set join style
*                6 = set cap
*
 setgsty  bss    0
          sx1    x5
          zr     x1,clrgsty
          sx1    x1-1        check for thickness
          zr     x1,setgthk
          sa1    x5+gstyles-1
          unpack x1
          ax5    18
          mx0    -6
          bx5    -x0*x5
          sx0    100b        set bit seven
          bx6    x0+x5
          out8p  x6          output with parity
          eq     outloop
*
 setgthk  bss    0
          unpack cthik
          ax5    18
          sendata x5
          eq     outloop
*
 clrgsty  bss    0
          unpack ccgsty
          eq     outloop
*
* /---   block=04-b format               2025/04/09. 00:24    source 
*i wb722.39
* not used in l0p - may be used in l1p
 f.e      parity 105b        e (uc)
 f.f      parity 106b        f (uc)
 f.k      parity 113b        k (uc)
*
 f.la     parity 141b        a (lc)
 f.lcb    parity 142b        b (lc)
 f.lc     parity 143b        c (lc)
 f.ld     parity 144b        d (lc)
 f.le     parity 145b        e (lc)
 f.lf     parity 146b        f (lc)
 f.lg     parity 147b        g (lc)
 f.lh     parity 150b        h (lc)
 f.li     parity 151b        i (lc)
 f.lj     parity 152b        j (lc)
 f.lk     parity 153b        k (lc)
 f.ll     parity 154b        l (lc)
 f.lm     parity 155b        m (lc)
 f.ln     parity 156b        n (lc)
 f.lo     parity 157b        o (lc)
 f.lp     parity 160b        p (lc)
 f.lq     parity 161b        q (lc)
 f.lr     parity 162b        r (lc)
 f.ls     parity 163b        s (lc)
 f.lt     parity 164b        t (lc)
 f.lu     parity 165b        u (lc)
 f.lv     parity 166b        v (lc)
 f.lw     parity 167b        w (lc)
 f.lx     parity 170b        x (lc)
 f.ly     parity 171b        y (lc)
 f.lz     parity 172b        z (lc)
*
*/ end fovlay5
* /---   block=04-c format               2025/04/03. 08:14    source 
*deck paramc
*d paramc.424
* l1p output
 arccode  equ    73b         extended arc code
 circode  equ    74b         extended circle code
 elipcod  equ    75b         extended ellipse code
 carccod  equ    76b         extended circular arc code
 boxcode  equ    77b         extended box code
 l1rcode  equ    100b        level 1 capabilities response req.
 clipcod  equ    101b        extended clip/window code
 fnamcod  equ    102b        send file name code
 trpsav   equ    103b        trap save
 trpend   equ    104b        trap end
 delacod  equ    105b        extended delay code
 pntcod2  equ    106b        paint code 2
 ttycode  equ    107b        set to tty mode
 xatcode  equ    110b        extended 18-bit at
 settsty  equ    111b        set text style
 prntcod  equ    112b        print screen code
 alrtcod  equ    113b        level 1 alert code
 palcode  equ    114b        palette code
 clrtsty  equ    115b        clear temp text style
 palcodp  equ    116b        palette code (protected)
 rstycod  equ    117b        reset current (saved) text style
 trpdel   equ    120b        trap delete
 forgcod  equ    121b        foreground color
 bacgcod  equ    122b        background color
 xccode   equ    123b        x center offset
 yccode   equ    124b        y center offset
 gstycod  equ    125b        set graphics style
 trpdisp  equ    126b        trap display
 trpwrit  equ    127b        trap write
 trpread  equ    130b        trap read
 trptest  equ    131b        trap test
 trpattc  equ    132b        trap attach
 strelcd  equ    133b        stretch end line
 strmlcd  equ    134b        stretch mid line
 strcrcd  equ    135b        stretch circle
 strexcd  equ    136b        stretch ellipse x
 streycd  equ    137b        stretch ellipse y
 strbccd  equ    140b        stretch box corner
 strbtcd  equ    141b        stretch box thickness
 strflcd  equ    142b        stretch fill
 strspcd  equ    143b        stretch stop
 trpstp   equ    144b        trap dragstop
 dpatcod  equ    145b        define pattern code
 dashcod  equ    146b        define dash code
 execcod  equ    147b        local exec code
 imsave   equ    150b        image save code
 imget    equ    151b        image get code
 iminfo   equ    152b        image info code
 imcopy   equ    153b        image copy code
 imclr    equ    154b        image clear code
 sbldcod  equ    155b        size bold
 snrmcod  equ    156b        size normal
 curscod  equ    157b        cursor code
 inhibcd  equ    160b        terminal inhibit code
 imdel    equ    161b        image delete code
 imchk    equ    162b        image check code
* /---   block=04-d format               2025/04/19. 13:09    source 
 cursty   equ    163b        cursor style
 curson   equ    164b        cursor on
 cursoff  equ    165b        cursor off
 scromar  equ    166b        scroll margin
 scroup   equ    167b        scroll up/down
 scroins  equ    170b        scroll insert
 scrodel  equ    171b        scroll delete
 prttxtw  equ    172b        print whole text screen
 prttxta  equ    173b        print area of text screen
 savterm  equ    174b        save term area
 resterm  equ    175b        restore term area
*
 endcode  equ    176b
*/ end paramc
* /---   block=04-e format               2025/04/12. 13:16    source 
*deck draws
*i draws.1222
 arc0     equ    savny+1     start of arc
*i draws.630
          sa6    arc0        start of arc
*i draws.683
          sa2    terscrn     l1p'/
          lx2    -1
          mx3    -1
          bx2    -x3*x2
          zr     x2,circov2
          eq     xcirc       l1p
*i draws.1187
*
* xcirc'; send a round circle.  x1=radius.
*
 xcirc    bss    0
          sa2    pcircle     arc'/
          nz     x2,xarc     is arc
          ux1    x1,b6       get radius
          lx1    x1,b6       as an integer
          mx2    -18         mask to 18 bits
          bx1    -x2*x1
          outcode circode
          eq     proco
*
 rten     data   10.
 degrad   data   572.9578    degrees per rad (180/pi) * 10
*
 xarc     bss    0
          ux1    x1,b6       get radius
          lx1    x1,b6       as an integer
          mx2    -18         mask to 18 bits
          bx1    -x2*x1
          outcode carccod+20000b
*                fixup and integerize * 10
          rj     aadjust     adjust start angle and length
          sa1    arc0        start angle
          sa3    arc         length
          mx2    -18         mask to 18 bits
          bx1    -x2*x1
*
          bx3    -x2*x3
          lx3    18
          bx1    x1+x3
          lx1    -24
          outp   0
          eq     proco
*
* /---   block=04-f format               2025/04/05. 16:03    source 
*
*         subroutine aadjust
*
*         adjust real arc start arc0 in radians
*         and real arc length arc also in radians
*         to integers in degrees times 10 in the
*         range 0 .. 3600
*
* entry   arc0 = start angle as real (signed)
*         arc = arc length as real (signed)
*         both in radians
*
* exit    adusted so both values are positive
*         and represent the same arc on the screen
*         values to be between 0 .. 3600 as integers.
*
*         may use these registers -
*         a1, a2, a3, x1, x2, x3, b6, a6, x6
*
*         example logic -
*         multiply arc0 and arc by 572.9578
*         convert both to signed integers
*         set arc0 to mod(arc0,3600)
*         if 0..3600 go on the length calc
*         flip start angle across axis
*         set arc0 to -(mod(-arc0,3600))
*         ----------- arc0 should now be 0 .. 3600
*         if arc > 3600 set arc to 3600
*         if arc < -3600 set arc to (mod(-arc,3600))
*         then set arc0 to arc0-arc
*         if arc0 < 0 set arc0 to 3600-arc0
*
* flpr     data   0
*
 aadjust  eq     *
*
*         multiply arc0 and arc by 572.9578
*         convert both to signed integers
          sa1    degrad
          sa2    arc0
          sa3    arc
          rx2    x1*x2
          rx3    x1*x3
          ux2    x2,b6
          lx2    x2,b6
          ux3    x3,b6
          lx6    x3,b6
          sa6    a3
          bx6    x2
          sa6    a2
*          sx6    -1          flag arc0 not flipped
*          sa6    flpr
*
* /---   block=04-g format               2025/04/20. 08:59    source 
*
*         set arc0 to mod(arc0,3600)
          bx1    x2
          rj     mod3600     will not change a negative
          bx6    x1
          sa6    arc0        partial progress
          pl     x1,stp1     arc0 done - 0..3600
*         set arc0 to -(mod(-arc0,3600))
          sx2    0           negate
          ix1    x2-x1
          rj     mod3600
          sx2    0           negate
          ix1    x2-x1
          bx6    x1
          sa6    arc0        save it
          pl     x1,stp1
*         arc0 is  < 0
*                flip start angle across axis
          sx2    3600
          ix6    x2+x1       new start
          sa6    arc0        save it
*          sx6    0
*          sa6    flpr        flag flipped
*
*         if arc > 3600 set arc to 3600
 stp1     sa1    arc         get length
          zr     x1,aadjust
          sx2    3600
          ix3    x1-x2
          ng     x3,stp2     brif arc < 3600
          bx6    x2
          sa6    a1          save 3600 and done
          eq     aadjust     return
*         if arc < -3600 set arc to (mod(-arc,3600))
 stp2     bss    0
*         arc = x1    -large num..3600
          pl     x1,aadjust  0..3600
*         arc < 0 here 
          sx3    0
          ix1    x3-x1       negate
          rj     mod3600
          bx6    x1
          sa6    arc
*                adjust start by length
          sa1    arc0        get start
          ix1    x1-x6       new start
          zr     x1,stpx
          pl     x1,stpx
          sx2    3600
          ix1    x2+x1
 stpx     bss    0
          bx6    x1
          sa6    arc0        save
          eq     aadjust     return
*
*
*         mod3600            cheap mod 3600 approx attempt
*         entry/exit   x1 = value to mod
*         entry and used -
*                      x2 = the mod to use (3600 our case)
*                      b6 = max iterations allowed (5)
*         uses  - x2,x3,b6
*
 mod3600  eq     *
          ng     x1,mod3600  negative - exit
          bx3    x1
          sx2    3600
          sb6    9
 modlp    bss    0
          ng     b6,mod3600  limit loops
          ix3    x3-x2
          ng     x3,mod3600  ok x1 is set
          bx1    x3
          sb6    b6-b1
          eq     modlp
*
* /---   block=05-a format               2025/04/20. 10:54    source 
*
*d draws.848
*i draws.847
*
          rj     ztlevel
          zr     x1,rcircl3
*
*         elipse - rotate 0
*
          bx2    x3
          bx4    x6
          ax2    60
          ax4    60
          bx2    x2-x3       abs(sizex)
          bx4    x4-x6       abs(sizey)
          sa1    radius
          rx2    x2*x1       x radius
          rx4    x4*x1       y radius
          ux2    x2,b2
          lx2    x2,b2
          ux4    x4,b2
          lx4    x4,b2
          mx1    -18
          bx2    -x1*x2
          bx4    -x1*x4
          sa1    pcircle
          nz     x1,earc
          bx1    x2
          outcode elipcod+20000b
          bx1    x4
          lx1    -24
          outp   0
          eq     proco
*
 earc     bss    0
          bx1    x2
          outcode arccode+30000b
          bx1    x4
          lx1    -24
          outp   0
*
          rj     aadjust     adjust start angle and length
          sa1    arc0        start angle
          sa3    arc         length
          mx2    -18         mask to 18 bits
          bx1    -x2*x1
*
          bx3    -x2*x3
          lx3    18
          bx1    x1+x3
          lx1    -24
          outp   0
          eq     proco
*
*
*/ end draws
*/ end of modset
* /---   block=05-b box                  2025/04/06. 17:51    source 
*/ --------------------------------------------------------
*/ add l1p support for -box-
*/ --------------------------------------------------------
*ident l1pbox                drs.           25/04/05.
*deck grafs2
*i grafs2.405
*
          sa2    terscrn     l1p'/
          lx2    -1
          mx3    -1
          bx2    -x3*x2
          nz     x2,l1pbox
*
*i grafs2.448
*
*      draw box, corners at screen xminus,yminus;xplus,yplus
*
*         send extended ascii box command
*
*         18/x, 18/y, 12/3, 12/boxcode
*         6/0, 18/thickness, 18/x, 18/y
*
 l1pbox   bss    0
*          sa1    tbwndow
*          bx0    x1          save windowing flag
*          sb1    1
*
          mx3    -18         mask for coords
          sa2    xminus
          bx1    -x3*x2
          lx1    18
          sa2    yminus
          bx2    -x3*x2
          bx1    x1+x2
*
          outcode boxcode+20000b    send box data
*
          sa2    siz
          sa3    boxincr
          ax3    59          extend sign
          bx6    x2-x3
          mx3    -18         mask for coords
          bx1    -x3*x6
          lx1    18
          sa2    xplus
          bx2    -x3*x2
          bx1    x1+x2
          lx1    18
          sa2    yplus
          bx2    -x3*x2
          bx1    x1+x2
          lx1    -24
          outp   0
*
          eq     proco
*
*/ end grafs2
*/ end of modset
* /---   block=05-c savedxxx             2025/04/07. 10:02    text  out
*deck comnds
*d yfclnup.7
          jumpov 8lstyle,style,0,nsetov,7,11010,styleov,0
*/ end comnds
*/ --------------------------------------------------------
*/ add l1p support for -style-
*/ --------------------------------------------------------
*ident l1pstyl                drs.           25/04/05.
*deck condc
*i condc.3392
          subov  styleov 
*/ end condc
*deck platxt
*i platxt.1266
*
 tbstyle  bss    1
*i platxt.2626
          subov  styleov
*/ end platxt
*deck comnds
*d yfclnup.7
          jumpov 8lstyle,style,0,styleov,0,11010,styleov,0
*/ end comnds
*/ end of modset
* /---   block=05-d stycommon            2025/04/22. 13:45    source 
*/ --------------------------------------------------------
*/ add l1p support for -style-, -image- (common files)
*/ --------------------------------------------------------
*ident l1pstyl                drs.           25/04/05.
*deck platxt
*i platxt.1266
*
 tbstyle  bss    1
*i platxt.2626
          subov  styleov
          subov  imageov
*/ end platxt
*/ end of modset
* /---   block=05-e style-cond           2025/04/08. 14:06    source 
*/ --------------------------------------------------------
*/ add l1p support for -style- (conden)
*/ --------------------------------------------------------
*ident l1psty1                drs.           25/04/06
*deck comnds
*d yfclnup.7
          jumpov 8lstyle,style,0,nsetov,7,11010,styleov,0
*/ end comnds
*deck covlay3
*i covlay3.2153
+         eq     stylein     7 = -style- command
*i covlay3.2296
*
          title  style command overlay
* 
          title  -style- command readin
*
*         -style- command read-in
*
*         style  graphics;tag1;tag2....
*
*         permitted tags';
*
*         clear                      0
*         thickness,var              1 (value)
*         pattern,var                2 (value)
*         dash,var                   3 (value)
*         option,(normal^'ifill^'ichordfill)  4 (0^'i1^'i3)
*         join,(miter^'ibevel^'iround)   5 (0^'i1^'i2)
*         cap,(flat^'iround^'isquare)    6 (0^'i1^'i2)
*
*
*      graphics;define;pattern;row1,row2,row3,row4,row5,row6,row7,row8
*
*      graphics;define;dash;run,skip^[;run,skip^]
*
*
*         style  touch;(normal^'ipixel)        (0^'i1)
*
*
*         style  text;clear
*
*         style  text;tag1;tag2....
*
*         permitted tags';
*         hthick
*         vthick
*         italic
*         underline
*         underline1
*         strikout
*         strikout1
*         shadow
*
*
*         first getvar code is a 0 for graphics
*         first getvar code is a 1 for touch
*         first getvar code is a 2 for text.
*         first getvar code is a 3 for pattern define
*         first getvar code is a 4 for dash define
*
*         then follow the getvar code for the tags, one 
*         getvar code for clear, two for the others.
*
 kcomm2  equ    56b
*
 getarg   eq     *
          sa1    wordpt
          sa1    x1
          zr     x1,err2few  too few tags
          call   vardo2
          eq     getarg
*
 nextarg  eq     *
          sa1    lastkey
          zr     x1,err2few  too few tags
          sx1    x1-kcomm2
          nz     x1,errterm
          call   getarg
          eq     nextarg
*
* omitted  eq     *
*          mx6    1
*          lx6    19
*          sa1    varbuf
*          sx7    x1+1
*          sa7    a1
*          sa6    varbuf+x7
*          eq     omitted
* /---   block=05-f style-cond           2025/04/08. 13:05    source 
*
*
 stylein  bss    0
          call   nxtnam      next tag = x6, sep = x1
          zr     x6,err2few
          bx7    x1
          sa7    lastkey
          sx1    x1-ksemic   must be ;
          nz     x1,errterm  bad delimiter
          sa1    pgrafix
          bx1    x1-x6       check for graphics form
          zr     x1,grafix
          sa1    ptouch
          bx1    x1-x6       check for touch form
          zr     x1,xtouch
          sa1    ptext
          bx1    x1-x6       check for text form
          zr     x1,xtext
          eq     errname     no match, error
*
 pgrafix  data   l*graphics*
 ptouch   data   l*touch*
 ptext    data   l*text*
*
 grafix   bss    0
          mx6    0
          sa6    varbuf+1    set to type 0 = graphics
          sx6    1
          sa6    varbuf      one tag present now
*
 gloop    bss    0
          sa1    wordpt
          sa1    x1
          zr     x1,stylex   done
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm  bad terminator
          call   nxtnam      next tag = x6, sep = x1
          zr     x6,errterm  ended with ;
          bx7    x1
          sa7    lastkey
          sa1    pdef
          bx2    x1-x6       check for define
          zr     x2,gdefine
          sa1    pclear
          bx2    x1-x6       check for clear form
          zr     x2,gclear
          sa1    pthick
          bx2    x1-x6       check for thickness form
          zr     x2,gthick
          sa1    ppater
          bx2    x1-x6       check for pattern form
          zr     x2,gpater
          sa1    pdash
          bx2    x1-x6       check for dash form
          zr     x2,gdash
          sa1    poption
          bx2    x1-x6       check for option form
          zr     x2,goption
          sa1    pjoin
          bx2    x1-x6       check for join form
          zr     x2,gjoin
          sa1    pcap
          bx2    x1-x6       check for cap form
          zr     x2,gcap
          eq     errname
*
 pdef     data   l*define*
 pclear   data   l*clear*
 pthick   data   l*thickness*
 ppater   data   l*pattern*
 pdash    data   l*dash*
 poption  data   l*option*
 pjoin    data   l*join*
 pcap     data   l*cap*
*
* /---   block=05-g style-cond           2025/04/06. 15:46    source 
*
 gclear   bss    0
          call   clrchk
          call   subtag,0
          eq     gloop
*
 gthick   bss    0
          call   normchk
          call   subtag,1
          call   nextarg
          eq     gloop
*
 gpater   bss    0
          call   normchk
          call   subtag,2
          call   nextarg
          eq     gloop
*
 gdash    bss    0
          call   normchk
          call   subtag,3
          call   nextarg
          eq     gloop
*
 goption  bss    0
          call   normchk
          call   subtag,4
          call   nxtnam
          zr     x6,err2few
          bx7    x1
          sa7    lastkey
          sa1    pnorm
          bx1    x1-x6
          zr     x1,g0
          sa1    pfill
          bx1    x1-x6
          zr     x1,g1
          sa1    pfill3
          bx1    x1-x6
          zr     x1,g3
          eq     errname
*
*
 g0       call   subtag,0
          eq     gloop
 g1       call   subtag,1
          eq     gloop
 g2       call   subtag,2
          eq     gloop
 g3       call   subtag,3
          eq     gloop
*
 pnorm    data   l*normal*
 pfill    data   l*fill*
 pfill3   data   l*chordfill*
*
*
 gjoin    bss    0
          call   normchk
          call   subtag,5
          call   nxtnam
          zr     x6,err2few
          bx7    x1
          sa7    lastkey
          sa1    pmiter
          bx1    x1-x6
          zr     x1,g0
          sa1    pbevel
          bx1    x1-x6
          zr     x1,g1
          sa1    pround
          bx1    x1-x6
          zr     x1,g2
          eq     errname
*
 pmiter   data   l*miter*
 pbevel   data   l*bevel*
 pround   data   l*round*
*
 gcap     bss    0
          call   normchk
          call   subtag,6
          call   nxtnam
          zr     x6,err2few
          bx7    x1
          sa7    lastkey
          sa1    pflat
          bx1    x1-x6
          zr     x1,g0
          sa1    pround
          bx1    x1-x6
          zr     x1,g1
          sa1    psquare
          bx1    x1-x6
          zr     x1,g2
          eq     errname
*
 pflat    data   l*flat*
 psquare  data   l*square*
 subtag   eq     *
          sa1    varbuf
          sx6    x1+1
          sa6    a1
          sb2    x6
          sx6    b1
          sa6    varbuf+b2
          eq     subtag
*
* /---   block=06-a style-cond           2025/04/08. 07:53    source 
*         check for ; or end of line
*
 clrchk   eq     *
          sa1    lastkey
          zr     x1,clrchk
          sx2    x1-ksemic
          zr     x2,clrchk
          eq     errterm
*
*         check for , or end of line
*
 normchk  eq     *
          sa1    lastkey
          zr     x1,normchk
          sx2    x1-kcomm2
          zr     x2,normchk
          eq     errterm
*
 stylex   bss    0           mark end of command
          sa1    lastkey
          nz     x1,errterm
          eq     mrklast
*
*
*         touch form
*
 xtouch   bss    0
          sx6    1
          sa6    varbuf+1    set to type 1 = touch
          sa6    varbuf      one tag present now
          sa1    wordpt
          sa1    x1
          zr     x1,err2few
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm  bad terminator
          call   nxtnam      next tag = x6, sep = x1
          zr     x6,errterm  ended with ;
          bx7    x1
          sa7    lastkey
          nz     x1,err2mny  only one tag permitted
          sa1    pnorm
          bx2    x1-x6       check for clear form
          zr     x2,tnorm
          sa1    ppixel
          bx2    x1-x6       check for clear form
          zr     x2,tpixel
          eq     errname
*
 ppixel   data   l*pixel*
*
 tnorm    bss    0
          call   subtag,0
          eq     stylex
*
 tpixel   bss    0
          call   subtag,1
          eq     stylex
*
*
 tval     equ    varbuf+2
*
 xtext    bss    0
          sx6    2
          sa6    varbuf+1    set to type 2 = text
          sa6    varbuf      two tags present now
          mx6    0
          sa6    tval        map of text styles
*
 tloop    bss    0
          sa1    wordpt
          sa1    x1
          zr     x1,tstylex  done
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm  bad terminator
          call   nxtnam      next tag = x6, sep = x1
          zr     x6,errterm  ended with ;
          bx7    x1
          sa7    lastkey
*
          call   txtfnd,txtwrd       find table entry
          ng     x1,errname  not found
          zr     x1,tclear   clear tag
          sb1    x1          bit / entry number
          mx6    1           single bit
          lx6    b1          shift into place
          sa1    tval        previous bits
          bx6    x6+x1       union them
          sa6    a1          put back
          eq     tloop
*
* /---   block=06-b style-cond           2025/04/06. 15:43    source 
*
 tclear   sa1    tval        clear must be only tag
          nz     x1,err2mny
          sx6    10000b
          sa6    a1
          eq     tloop
*
 tstylex  sa1    tval
          zr     x1,err2few
          eq     stylex
*
*
*
 txtfnd   eq     *
          mx1    0
          sa2    b1
          sb1    1
 txtlp    bx2    x6-x2
          zr     x2,txtfnd   found entry, x1 = index
          sa2    a2+b1
          sx1    x1+b1
          nz     x2,txtlp
          mx1    -1
          eq     txtfnd
*
*
 txtwrd   data   l*clear*
          data   l*hthick*
          data   l*vthick*
          data   l*italic*
          data   l*underline*
          data   l*underline1*
          data   l*strikeout*
          data   l*strikeout1*
          data   l*shadow*
          data   0
*
 gdefine  bss    0
          call   clrchk
          sa1    varbuf
          sx1    x1-1
          nz     x1,errname  not first tag after graphics
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm  bad terminator
          call   nxtnam      next tag = x6, sep = x1
          zr     x6,errterm  ended with ;
          bx7    x1
          sa7    lastkey
          call   clrchk
          sa1    ppater
          bx2    x1-x6       check for pattern
          zr     x2,patdef
          sa1    pdash
          bx2    x1-x6       check for dash
          zr     x2,dashdef
          eq     errname
*
 patdef   bss    0
          sx6    3
          sa6    varbuf+1    set to pattern define
          call   getarg      pattern number
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm  bad terminator
          call   getarg
          call   nextarg
          call   nextarg
          call   nextarg
          call   nextarg
          call   nextarg
          call   nextarg
          call   nextarg
          sa1    lastkey
          nz     x1,err2mny
          eq     mrklast
*
*
* /---   block=06-c style-cond           2025/04/08. 09:23    source 
*
 dashdef  bss    0           get up to 4 pairs of tags
          sx6    4
          sa6    varbuf+1    set to dash define
          call   subtag,0    no pairs yet (varbuf+2)
          call   getarg      dash slot number
*
 dashlp   bss    0
          call   getpair
          sa1    varbuf+2    inc number of pairs
          sx6    x1+1
          sa6    a1
          sa1    lastkey
          zr     x1,mrklast  done
          sx6    x6-4
          zr     x6,err2mny  too many pairs ( max of 4 )
          eq     dashlp
*
 getpair  eq     *
          sa1    lastkey
          sx1    x1-ksemic   must be ;
          nz     x1,errterm  bad terminator
          call   getarg      get first of pair
          sa1    lastkey
          sx1    x1-kcomm2   must be ,
          nz     x1,errterm  bad terminator
          call   getarg      get second of pair
          eq     getpair
*
*
*/ end covlay3
*/ end of modset
* /---   block=06-d style-exec           2025/04/22. 13:52    source 
*/ --------------------------------------------------------
*/ add l1p support for -style- (exec)
*/ --------------------------------------------------------
*ident l1psty2                drs.           25/04/06
*deck draws
*i draws.1226
          eject
          title  -style- command
*
*         style  graphics;tag1;tag2....
*
*         permitted tags';
*
*         clear                      0
*         thickness,var              1 (value)
*         pattern,var                2 (value)
*         dash,var                   3 (value)
*         option,(normal^'ifill^'ichordfill)  4 (0^'i1^'i3)
*
*         these may be added later'; (added drs)
*
*         join,(miter^'ibevel^'iround)   5 (0^'i1^'i2)
*         cap,(flat^'iround^'isquare)    6 (0^'i1^'i2)
*
*
*         style  touch;(normal^'ipixel)
*
*
*         style  text;clear
*
*         style  text;tag1;tag2....
*
*         permitted tags';
*         hthick
*         vthick
*         italic
*         underline
*         underline1
*         strikout
*         strikout1
*         shadow
*
*         first getvar code is a 0 for graphics
*         first getvar code is a 1 for touch
*         first getvar code is a 2 for text.
*         first getvar code is a 3 for define pattern
*         first getvar code is a 4 for define dash
*
*         then follow the getvar code for the tags, one 
*         getvar code for clear, two for the others.
*
*
 styleov  ovrlay
*
* /---   block=06-e style-exec           2025/04/12. 13:19    source 
***********************************************************
*
*         tag macro for handling command tags
*
          purgmac tag
 tag      macro
 
*         increment count of tags processed
 
          sa1    ctag
          sx6    x1+1
          sa6    a1
 
*         check for end of tags
 
          sa2    numargs
          bx2    -x2
          sb1    x1
          sb1    b1+x2
          pl     b1,proco
 
*         fetch getvar code
 
          sa2    varbux+x1
          bx5    x2
 
*         check if omited
 
          lx2    1
          ng     x2,proco
 
*         evaluate
 
          ngetvar
 
          endm
*
***********************************************************
* /---   block=06-f style-exec           2025/04/20. 15:01    source 
***********************************************************
*
          sx6    20          max tags
          sa5    a5+0
          call   getargx     move tags to *varbufx*
          sa6    numargs
          mx6    0
          sa6    ctag        current tag = 0
          rj     ztlevel
          zr     x1,proco    not l1p terminal
*
          tag                get type of style command
*
          zr     x1,gloop    graphics type
          sx1    x1-1
          zr     x1,ttype    touch type
          sx1    x1-1
          zr     x1,txtsty   text style
          sx1    x1-1
          zr     x1,defpat   define pattern
          sx1    x1-1
          zr     x1,defdash  define dash
          eq     proco       not supported
*
*         output loop for graphics styles
*
 gloop    bss    0
*
*         get subtype
*
          tag                will exit if done
*
*         save subtype
*
          bx6    x1
          sa6    tagv
*
          zr     x1,gclear   clear has no other tag
*
*         get tag for subtype
*
          tag
*
 ggo      bss    0
          mx2    -18
          bx1    -x2*x1
          sa2    tagv
          lx1    18
          bx1    x1+x2
          sx2    x2-4        check for option form
+         nz     x2,*+1      not option form
          rj     setopt      set/clear option flag
+         output gstycod
          eq     gloop
*
* /---   block=06-g style-exec           2025/05/01. 09:09    source 
*
 gclear   bss    0
          sa2    tbtcap
          mx3    -2          clear fill bits
          lx3    cp.chrd     move up
          bx6    x3*x2
          sa6    a2
          eq     ggo
 
 setopt   eq     *
          sa2    terscrn     check for extended terminal
          lx2    exal1
          pl     x2,setopt   not extended, ignore
*
          sa2    tbtcap
          bx3    x1
          lx3    60-18       get fill bit in lower
          mx0    -2
          bx3    -x0*x3      lower 2 bits only
          lx3    cp.chrd     move into place
          lx0    cp.chrd     shift mask to top
          bx6    x0*x2       clear bits
          bx6    x6+x3       add new bits if set
          sa6    a2
          mx0    -1
          lx0    19
          bx1    x0*x1
          eq     setopt
*
*
*
*
*         touch type
*
 ttype    bss    0
          sa1    terscrn     check for extended terminal
          lx1    exal1
          pl     x1,proco    not extended, ignore
*
          tag
          mx0    -1
          bx1    -x0*x1      mask to lower bit only
          lx1    cp.pixt           move up to third bit
          sa2    tbtcap      get student bank word
          lx0    cp.pixt           move mask
          bx6    x0*x2       clear previous flag
          bx6    x6+x1       add new flag
          sa6    a2
          eq     proco
*
*
 txtsty   bss    0
          sa1    terscrn     check for extended terminal
          lx1    exal1
          pl     x1,proco    not extended, ignore
*
          tag
          sx2    10000b
          bx2    x2*x1
          nz     x2,txtclr
          sa2    tbstyle
          bx6    x1+x2
          sa6    a2
          sx1    x6
          output settsty
          eq     proco
*
 txtclr   bss    0
          sx2    7777b
          bx6    x2*x1
*          sa6    tbstyle
          sa1    tbstyle
          mx2    -18
          bx1    x2*x1
          bx6    x1+x6
          sa6    a1
          sx1    x6
          output settsty
          eq     proco
*
* /---   block=07-a style-exec           2025/04/06. 23:43    source 
*         user defined pattern
 
 build4   macro
*
*         form word containing 4 8-bit pattern bytes and output them
*
          tag
          mx0    -8
          bx6    -x0*x1
          sa6    build
          tag
          mx0    -8
          bx6    -x0*x1
          lx6    8
          sa1    build
          bx6    x1+x6
          sa6    a1
          tag
          mx0    -8
          bx6    -x0*x1
          lx6    18
          sa1    build
          bx6    x1+x6
          sa6    a1
          tag
          mx0    -8
          bx6    -x0*x1
          lx6    18+8
          sa1    build
          bx7    x1+x6
          sa2    moutloc
          sx6    x2+1
          sa6    a2
          sa7    mout+x2
          endm
*
*          ext    ttdstyl
 
 defpat   bss    0
*          call   ttdstyl
*          pl     x1,proco
 
          tag                get pattern slot number
          mx0    -6
          bx1    -x0*x1      limit to 6 bits
          output dpatcod+030000b      three words of output
 
          build4
          build4
          eq     proco
*
*
*         define a dash style
*
*
 defdash  bss    0
*          call   ttdstyl
*          pl     x1,proco
 
          tag                x1 = number of run/skip pairs
          bx6    x1
          sa6    pairs
 
          tag                get dash slot number
          mx0    -4
          bx1    -x0*x1      limit to 4 bits
          lx1    18
          sa2    pairs
          bx1    x1+x2
          sx2    x2+1
          lx2    12
          sb3    x2          number of words in mout packet
          output dashcod+b3
 
 dashlp   bss    0
          tag                run length
          mx0    -16
          bx6    -x0*x1
          sa6    build
          tag                skip length
          mx0    -16
          bx6    -x0*x1
          lx6    18
          sa1    build
          bx7    x1+x6
          sa2    moutloc
          sx6    x2+1
          sa6    a2
          sa7    mout+x2
          sa1    pairs       end test
          sx6    x1-1
          sa6    a1
          nz     x6,dashlp
          eq     proco
*
* /---   block=07-b style-exec           2025/04/07. 17:26    source 
*
*         -getargx-
*
*         routine to unpack all getvar codes for a
*         command into *varbux* for commands which
*         use routine *mrklast* to mark off the last
*         getvar code of a variable-argument command
*
*         on entry'; x6 = maximum number desired
*         on exit '; x6 = number of arguments found
*
*
*
 getargx  eq     *
          sb3    x6          b3 = number of args to get
          sb1    1           b1 = 1
          bx6    x5
          sb2    b0          b2 = current varbuf bias
          ng     x6,mrkfnx   if negative then mark is found
          sa6    varbux      store with 1st var code ljust
          sb2    b1          bias = 1
          lx6    xcodel
          ng     x6,mrkfnx   if negative then mark is found
          sa6    varbux+1    store with 2nd var code ljust
          sb2    b2+b1       bias = 2
          lx6    60-xcmndl-xcodel
          mx0    2*xcodel+xcmndl
          bx6    -x0*x6      x6 = extra storage pointer
          sa1    b5+x6       x1 = 1st word of extra storage
 getarg1  bx6    x1
          ng     x6,mrkfnx   if negative then mark is found
          sa6    varbux+b2
          sb2    b2+b1       next argument
          lx6    xcodel
          ng     x6,mrkfnx   if negative then mark is found
          sa6    varbux+b2
          sb2    b2+b1       next argument
          lx6    xcodel
          ng     x6,mrkfnx   if negative then mark is found
          sa6    varbux+b2
          sb2    b2+b1       next argument
          sa1    a1+b1       x1 = next extra storage word
          lt     b2,b3,getarg1  loop if more to go...
 mrkfnx   mx0    1           form sign bit mask
          bx6    -x0*x6      mask top bit off getvar code
          sa6    varbux+b2   store the unmarked code
          sx6    b2+b1       current count of arguments
          eq     getargx
*
 pairs    bss    1
 build    bss    1
 ctag     bss    1
 tagv     bss    1
 varbux   bssz   22
*
          endov
*
*/ end draws
*/ end of modset
* /---   block=07-c image-cond           2025/04/28. 11:46    source 
*/ --------------------------------------------------------
*/ add l1p support for -image- (conden)
*/ --------------------------------------------------------
*ident l1pima1                drs.           25/04/09
*deck comnds
*d yfclnup.8
          jumpov 8limage,image,0,covl3b,17,11010,imageov,0
*/ end comnds
*deck covlay3
*i covlay3.2321
+         eq     imagein     17 = image
*i covlay3.2963
*
*
**********************************************************
*
*         image  save;x1,y1;x2,y2;clip';^'imem';,^$^'ifile,filelth;forma
*         getvar 2-5 are x1,y1,x2,y2
*         getvar 6 is filename or 'i'd^$
*         getvar 7 is filelth (or nothing)
*         getvar 8 is format (0=local, 1=pcx)
*
*         image  get;x1,y1;x2,y2;dx1,dy1;dx2,dy2;src;paletteflag
*         getvar 2-9 are coords
*         getvar 10 is filename or 'i'd^$
*         getvar 11 is filelth or nothing
*         getvar 12 is palette load flag
* 
*         image  info;src;xsize,ysize
*         getvar 2 is filename or 'i'd^$
*         getvar 3 is filelth or nothing
*         getvar 4 is xsize
*         getvar 5 is ysize
*
*         image  copy;x1,y1;x2,y2;dx1,dy1;dx2,dy2
*         getvar 2-9 are coords
*
*         image delete;dest
*         getvar 2 is filename or 'i'd^$
*         getvar 3 is filelth or nothing
*
*         image check
*
*
*         first getvar code';
*
*         low 3 bits are subtype
*         0      save
*         1      get
*         2      info
*         3      copy
*         4      delete
*         5      check
*         bits 3-5 are dst/src type
*         0      file
*         1      mem';
*         2      clip';
*
*
 xferfnd  eq     *
          mx1    0
          sa2    b1
          sb1    1
 xferlp   bx2    x6-x2
          zr     x2,xferfnd  found entry, x1 = index
          sa2    a2+b1
          sx1    x1+b1
          nz     x2,xferlp
          mx1    -1
          eq     xferfnd
*
* /---   block=07-d image-cond           2025/04/10. 13:40    source 
 kcomm2  equ    56b
*
 getarg   eq     *
          sa1    wordpt
          sa1    x1
          zr     x1,err2few  too few tags
          call   vardo2
          eq     getarg
*
 nextarg  eq     *
          sa1    lastkey
          zr     x1,err2few  too few tags
          sx1    x1-kcomm2
          nz     x1,errterm
          call   getarg
          eq     nextarg
*
*
 imagein  bss    0
          call   nxtnam      get first tag
          zr     x6,err2few
          bx7    x1
          sa7    lastkey     must end with ;
          call   xferfnd,imtag1
          ng     x1,errname  unrecognized type
          sx6    1
          sa6    varbuf      one getvar so far
          bx6    x1          command subtype
          sa6    varbuf+1    save it
          sx1    x6-5        check for ',check',
          zr     x1,imagdun  it'7s all over
          sa2    lastkey
          sx2    x2-ksemic
          nz     x2,errterm
          sx1    x6-2        check for info type
          zr     x1,imfil    skip to file parse
          sx1    x6-4        chk for delete type
          zr     x1,imfil    skip to file parse
          rj     imcord      process 1st ',box',
          sa1    lastkey
          sx1    x1-ksemic
          nz     x1,errterm
          sa1    varbuf+1
          zr     x1,imfil    if save, goto file parse
          rj     imcord      process 2nd ',box',
          sa1    varbuf+1
          sx1    x1-3        check for copy type
          zr     x1,imagdun
*
 imfil    bss    0
          sa1    wordpt
          bx7    x1
          sa7    varbuf+20   save it
          call   nxtnam      get file name
          bx7    x1
          sa7    lastkey
          sx1    x1-ksemic
          nz     x1,imfil2   must be filename,filelth
          sa1    immem
          ix1    x1-x6
          nz     x1,imfil3   must be clip';
          call   nxtnam
          nz     x6,errterm
          bx7    x1
          sa7    lastkey
          sx1    x1-kcomm2
          nz     x1,errterm
          call   getarg      get slot number
          sa1    varbuf
          sx6    x1+1        skip getvar for filelth
          sa6    varbuf
          sa1    varbuf+1    get 1st getvar
          sx2    8           1 in dst/src field
          bx6    x1+x2
          sa6    a1          return it
          eq     imfil4      done
* /---   block=07-e image-cond           2025/04/10. 03:59    source 
 imfil3   bss    0           clip'; check
          sa1    imclip
          ix1    x1-x6
          nz     x1,errname  not recognized
          sa1    varbuf
          sx6    x1+2        skip getvars for id/filelth
          sa6    varbuf
          sa1    varbuf+1    get 1st getvar
          sx2    16          2 in dst/src field
          bx6    x1+x2
          sa6    a1          return it
          call   nxtnam
          nz     x6,errterm
          bx6    x1          separator
          sa6    lastkey     store it
          bx7    x1
          eq     imfil4      done
 imfil2   bss    0           filename,filelth
          sa1    varbuf+20   recover wordpt
          bx7    x1
          sa7    wordpt
          call   getarg      get it
          call   nextarg     get length
 imfil4   bss    0
*
          sa1    varbuf+1    get subtype
          mx2    57
          bx1    -x2*x1      mask field
          sx2    x1-4        chk for delete
          zr     x2,imagdun
          sa2    lastkey
          sx2    x2-ksemic
          nz     x2,errterm
          sb1    x1
          jp     *+b1+1
 +        eq     imsve
 +        eq     imget
 +        eq     iminf
 imsve    bss    0
 imget    bss    0
          call   getarg      format or palette load flag
          eq     imagdun
*
 iminf    bss    0
          call   getarg      xsize arg
          ng     x1,errstor
          call   nextarg     ysize arg
          ng     x1,errstor
          eq     imagdun
*
 imcord   ps
          call   getarg      read x1
          call   nextarg     read y1
          sa1    lastkey
          sx2    x1-ksemic
          nz     x2,errterm
          call   getarg      read x2
          call   nextarg     read y2
          eq     imcord
*
 imagdun  sa1    lastkey
          nz     x1,errterm
          sa1    varbuf      number of getvar codes
          eq     varfin
*
 imtag1   data   l*save*
          data   l*get*
          data   l*info*
          data   l*copy*
          data   l*delete*
          data   l*check*
          data   0
*
 imclip   data   o03141120700000000000
 immem    data   o15051570000000000000
*
*/ end covlay3
*/ end of modset
* /---   block=07-f image-exec           2025/04/20. 09:05    source 
*/ --------------------------------------------------------
*/ add l1p support for -image- (exec)
*/ --------------------------------------------------------
*ident l1pima2                drs.           25/04/10
*deck draws
*i draws.22
          ext    process,ztlevel
*i draws.1227
*
          title  image command execution
*
*
****************************************************
*
*
*         'accepts 5 to 12 getvar codes
*
*         first getvar code';
*
*         low 3 bits are subtype
*         0      save
*         1      get
*         2      info
*         3      copy
*         4      delete
*         5      check
*         bits 3-5 are dst/src type
*         0      file
*         1      mem';
*         2      clip';
*
*         image  save;x1,y1;x2,y2;clip';^'imem';,^$^'ifile,filelth;forma
*         getvar 2-5 are x1,y1,x2,y2
*         getvar 6 is filename/'i'd^$ or undefined if clipboard type
*         getvar 7 is filelth or undefined for mem';/clip';
*         getvar 8 is format (0=local, 1=pcx)
*
*         image  get;x1,y1;x2,y2;dx1,dy1;dx2,dy2;src;paletteflag
*         getvar 2-9 are coords
*         getvar 10 is filename/'i'd^$ or undefined if clip';
*         getvar 11 is filelth or undefined for clip';/mem';
*         getvar 12 is palette load flag
* 
*         image  info;src;xsize,ysize
*         getvar 2 is filename or 'i'd^$ or undefined for clip';
*         getvar 3 is filelth or undefined for clip';/mem';
*         getvar 4 is xsize (storeable)
*         getvar 5 is ysize (storeable)
*
*         image  copy;x1,y1;x2,y2;dx1,dy1;dx2,dy2
*         getvar 2-9 are coords
*
*         image delete;dest
*         getvar 2 is filename/'i'd^$ or undefined if clip';
*         getvar 3 is filelth or undefined for clip';/mem';
*
*         image  check
*
**********************************************************
* /---   block=07-g image-exec           2025/04/22. 14:00    source 
*
*         note';  echo is currently ignored due to
*         syslib incompatability
*
*         zreturn *not* set
*
* 
*         echos from level 1 program
* 
*         0      success
*         1      file operations disabled
*         2      no filename in buffer
*         3      can'7t open file
*         4      file not in format readable by -image-
*         5      slot 'i'd out of range
*         6      terminal has insufficient memory for operation
*         7      'i'd buffer is empty
*         8      filename sumchk error
*         9      program doesn'7t support this file format
*         10     subrectangle or coordinates out of range
*
************************************************************
*
*         zreturn values
*
*         -1     success
*         0      terminal doesn'7t support -image-
*         1      'i'd out of range
*         2      terminal lacks memory to accomplish operation
*         3      'i'd buffer is empty
*         4      can'7t open file
*         5      file not -image- readable
*         6      filename or communications error
*         7      file operations disabled
*         8      timeout
*
*         9      terminal doesn'7t support file format
*         10     subrectangle or coordinates out of range
*
* /---   block=08-a image-exec           2025/04/30. 19:56    source 
*
 imageov  ovrlay
          ext    erxval
*
*          sa1    lesscm+lstouse  test for system lesson
*          ng     x1,finxok   skip finish unit check if system lesson
          finish
 finxok   bss    0
          sa1    tbtcap      get capabilites word
          lx1    59-cp.img           image bit to sign
          pl     x1,noimage  not supported
          ngetvar            get flags
          mx2    57
          bx1    -x2*x1      get subtype
          sb1    x1
          jp     *+b1+1
 +        eq     imsavex
 +        eq     imgetx
 +        eq     iminfox
 +        eq     imcopyx
 +        eq     imdelx
 +        eq     imchkx
*
 imsavex  bss    0
          sx6    8
          call   getcodx     unpack getvar codes
          sa1    varbuf+7    check bounds on format arg
          bx5    x1
          ngetvar
          ng     x1,erxval
          sx2    x1-2
          pl     x2,erxval
          call   fileout,varbuf+5    transmit destination
          outcode imsave+060000b
          call   outw,varbuf+1,4     send src box to terminal
          sa1    varbuf+7
          bx5    x1
          ngetvar
          lx1    11          shift to position in output word
          sx6    5           offset of 'i'd ^$
          rj     im07
          eq     imecho
*
 imgetx   bss    0
          sx6    12
          call   getcodx
          call   fileout,varbuf+9    transmit source
          outcode imget+0120000b
          call   outw,varbuf+1,8     send subrect+dest to terminal
          sa1    varbuf+11           get palette flag
          bx5    x1
          ngetvar
          pl     x1,img0
          zr     x1,img0
          sx1    04000b              set palette load bit
          eq     imggo
 img0     mx1    0                   send without pal bit
 imggo    bss    0
          sx6    9           offset of 'i'd value
          rj     im07
          eq     imfast
*
 iminfox  bss    0
          mx6    0           flag not to send imclr code
          sa6    tbintsv+12
          mx3    1           test the touch enabled bit
          lx3    enablt
          sa1    fstflgs     merge bits
          bx3    x1*x3
          nz     x3,xpkey1   if set, skip clear
          mx6    59
          sa6    a6
* /---   block=08-b image-exec           2025/04/11. 10:02    source 
*
 xpkey1   bss    0
          sx6    5
          call   getcodx
          call   fileout,varbuf+1    transmit inquired object
          outcode iminfo+020000b
          sx6    1           offset of 'i'd field
          rj     im07
          eq     imtouch
*
 imcopyx  bss    0
          sx6    9
          call   getcodx
          outcode imcopy+0110000b
          call   outw,varbuf+1,8     send src+dest to terminal
          eq     imfast
*
 noimage  bss    0
          mx6    0
          sa6    treturn
          eq     process
 imdelx   bss    0
          sx6    3
          call   getcodx
          call   fileout,varbuf+1    transmit source
          outcode imdel+020000b
          sx6    1           offset of 'i'd field
          rj     im07
          eq     imecho
*
 imchkx   bss    0
          outcode imchk
          eq     imecho
*
 imfast   bss    0
          mx6    59
          sa6    treturn
          eq     proco
*
*         subroutine for forming bits 0-10 of output word
*         for src/dst being used.
*
*         on entry, x6 = offset in varbuf of 'i'd^$ for mem'; option
*                   x1 = bits 8+ of output word
*
 im07     ps
          sa6    varbuf+16   save 'i'd offset
          bx6    x1
          sa6    varbuf+15   save preset bits
          sa1    varbuf
          bx5    x1
          ngetvar
          ax1    3
          zr     x1,im0f     file type
          sx1    x1-1
          zr     x1,im0m     memory type
          sx1    x1-1
          zr     x1,im0c     clipboard
          jp     *+0400000b  bad value planted
 im0f     sa1    varbuf+15   get preset bits
          eq     imsendw     send word
 im0m     bss    0
          sa1    varbuf+16   get 'i'd offset
          sb1    x1
          sa1    varbuf+b1
          bx5    x1
          ngetvar            get 'i'd
          mx2    59          add 1 to 'i'd
          ix1    x1-x2
          mx2    52
          bx1    -x2*x1      0-255 range
          sx2    0400b       set memory bit
          bx1    x1+x2
          sa2    varbuf+15   get preset bits
          bx1    x1+x2
          eq     imsendw
 im0c     bss    0
          sa1    varbuf+15   get preset bits
          sx2    01000b      clipboard
          bx1    x1+x2
          eq     imsendw
* /---   block=08-c image-exec           2025/04/10. 08:13    source 
*
*         'on entry, x1 is word to output
*
 imsendw  bss    0
          bx6    x1
          sa2    moutloc
          sa6    mout+x2
          sx6    x2+1
          sa6    a2
          eq     im07
*
*         subroutine for setting up transmit of filename to terminal
*
*         on entry b1 = address of filename getvar
*                  b1+1 = address of filenamelength getvar
*
 fileout  ps
          sx6    b1
          sa6    varbuf+17
          sa1    varbuf      get type
          bx5    x1
          ngetvar
          ax1    3           isolate type of dest
          mx2    57
          bx1    -x2*x1      get low 3 bits
          nz     x1,fileout  if not filename, skip it
          sa1    varbuf+17   get pointer back
          sa1    x1
          bx5    x1
          ngetvar            get file name
          sx6    a1          save address
          sa6    varbuf+15
          sa1    varbuf+17   get back pointer
          sa1    x1+1        filename length
          bx5    x1
* following code from the -trap- overlay
          ngetvar
          ng     x1,erxval   must be 1<=lth<=100
          zr     x1,erxval
          sx2    x1-101
          pl     x2,erxval
          sx6    x1
          sa6    varbuf+16
          sx2    x1+9        compute number of words
          sx3    10
          px3
          nx3
          px2
          nx2
          fx2    x2/x3
          ux6,b1 x2
          lx6    b1
          sa6    varbuf+17   number of words
          sa1    varbuf+15
          sa0    x1
          sx1    x6
          call   bounds
          sa1    varbuf+16
          sa2    varbuf+17
          call   sendfn,a0,x1,x2     transmit filename
          eq     fileout
*
* /---   block=08-d image-exec           2025/04/22. 14:07    source 
*
*         subroutine for sending several words to terminal.
*
*         on entry, b1 = address of getvar of word1
*                   b1+1,b1+2,...,b1+b2-1 subsequent getvars
*                   b2 = number of words to send
*
 outw     ps
 outl     bss    0
          sa1    b1          get next getvar
          bx5    x1
          sx6    b1+1        next getvar
          sa6    varbuf+15
          sx6    b2-1        counter
          sa6    varbuf+16
          ngetvar
          bx6    x1
          sa2    moutloc
          sa6    mout+x2
          sx6    x2+1
          sa6    a2
          sa1    varbuf+15
          sb1    x1          get next pointer
          sa1    varbuf+16
          sb2    x1          get next count
          zr     b2,outw
          eq     outl
*
 sendfn   ps
          sx1    fnamcod     out code
          sx2    1+b3        length of package
          lx2    12          into position
          ix3    x1+x2       out code and length
          sx1    b2          number of chars
          output x3
          sa2    moutloc     inc moutloc by text lth
          sx6    x2+b3
          sa6    a2
          sa1    b1-1
 sendlp   bss    0           copy to mout buffer
          sa1    a1+1
          bx6    x1
          sa6    mout+x2
          sx2    x2+1
          sb3    b3-1
          gt     b3,b0,sendlp
          eq     sendfn
*
 imecho   bss    0
          eq     proco       disable wait for echo'.
*
*
*          getclk x1,sysclok
          sa1    xslclok
          sx2    9000        wait 9 seconds
          ix6    x1+x2
          sa6    tbintsv+15
          call   savles
 imelp    tutim  -1,tutup,anykey
          stopchk
          sa1    key
          sx2    x1-3200b    lowest echo key
          ng     x2,imoutc
          sx2    x1-3200b-11 largest echo+1
          pl     x2,imoutc
          sx6    x1-3200b
          sa6    tbintsv+15
          eq     imeex
*
* /---   block=08-e image-exec           2025/04/10. 09:11    source 
*
* imoutc   getclk x1,sysclok
 imoutc   bss    0
          sa1    xslclok
          sa2    tbintsv+15
          ix1    x1-x2
          ng     x1,imelp    not timeout, try some more
          sx6    -1
          sa6    tbintsv+15
 imeex    call   restles
          sa1    tbintsv+15
          sb1    x1
          sa1    b1+imagtab+1
          bx6    x1
          sa6    treturn
          eq     proco
*
 imtouch  bss    0
          sa1    varbuf+3    x dimension dest.
          bx6    x1
          sa6    tbintsv+13  save it
          sa1    a1+1        y dimension dest.
          bx6    x1
          sa6    tbintsv+14  save it
*          getclk x1,sysclok
          sa1    xslclok
          sx2    9000        9 seconds
          ix6    x1+x2
          sa6    tbintsv+15
          call   savles
 itlp     tutim  -1,tutup,anykey
          stopchk
          sa1    key
          bx2    x1
          ax2    8
          sx2    x2-1
          nz     x2,itoutc
          mx6    0
          sa6    tbintsv+15
          eq     itex
* itoutc   getclk x1,sysclok
 itoutc   bss    0
          sa1    xslclok
          sa2    tbintsv+15
          ix1    x1-x2
          ng     x1,itlp     not timeout, try again
          sx6    -1
          sa6    tbintsv+15
 itex     call   restles
          sa1    tbintsv+12  check on touch enable condition
          zr     x1,itex2
          output imclr
 itex2    bss    0
          sa1    tbintsv+15
          ng     x1,imterr
          sa2    tbintsv+13          x getvar
          bx5    x2
          sa1    xtouchw
          bx6    x1                  touch key
          ax6    18
          mx2    42
          bx6    -x2*x6              mask it to 18
          mx3    42
          bx3    -x3
          ix3    x3-x6       check for all 18 bits set (error return)
          nz     x3,imxput
          bx6    x1                  touch key
          mx2    42
          bx1    -x2*x6              low 18 bits of 'y
          eq     imterr
*
* /---   block=08-f image-exec           2025/04/22. 14:08    source 
*
 imxput   nputvar
          sa1    xtouchw             touch word
          sa2    tbintsv+14          y getvar
          bx5    x2
          bx6    x1                  touch key
          mx2    42
          bx6    -x2*x6              low 18 bits
          nputvar
          mx6    59
          sa6    treturn
          eq     proco
 imterr   bss    0
          sb1    x1
          sb2    10
          gt     b1,b2,imterr2
          sa1    b1+imagtab+1
          bx6    x1
          sa6    treturn
          eq     proco
 imterr2  sx6    8
          sa6    treturn
          eq     proco
*
*         table for translating echo values or touch values
*         to zreturn values.
*
 imagtab  data   8           timeout
          data   -1          success
          data   7           no file ops
          data   6           no file name in buffer
          data   4           can'7t open file
          data   5           not an -image- file
          data   1           'i'd 'o'o'r
          data   2           terminal out of memory
          data   3           buffer is empty
          data   6           file name sumchk error
          data   9           bad file format
          data   10          rectangle 'o'o'r
*
          endov
*/ end draws
*/ end of modset
* /---   block=08-g terms                2025/04/19. 22:30    source 
*ident imgterm
*deck tutorx
*i jvterm.2
          ext    ztlevel
*i jvterm.9
          rj     ztlevel
          zr     x1,nosav
          outcode savterm
 nosav    bss    0
*
*
*i jvterm.18
          rj     ztlevel
          zr     x1,norest
          outcode resterm
 norest   bss    0
*
*
* /---   block=09-a window               2025/05/08. 15:34    source 
*ident l1pwind
*deck grafs2
*i grafs2.37
          ext    ztlevel
*i grafs2.374
          rj     ztlevel
          zr     x1,process
          bx1    x6
          outcode clipcod
*i grafs2.381
          rj     ztlevel
          zr     x1,process
          bx1    x6
          outcode clipcod
*deck logicx
*i logicx.44
          ext    ztlevel,tgroup
*i utcolor.16
          rj     ztlevel
          zr     x1,nol1p
          rj     tgroup
          zr     x1,nol1p
          sx1    0           no clipping
          outcode clipcod
*                            clear top 3 bits of tbtcap
*                            2 fill bits and touch bit
          sa1    tbtcap
          mx0    3
          bx6    -x0*x1
          sa6    a1
*                            now recenter wide screen
          sa1    terscrn
          lx1    -24
          mx2    -10
          bx1    -x2*x1
          sx2    512
          ix1    x1-x2
          lx1    -1
          outcode xccode
          sa1    terscrn
          mx2    12
          bx1    -x2*x1
          sx2    512
          lx2    -12
          bx6    x1+x2
          sa6    a1
 nol1p    bss    0
* /---   block=09-b wide-fram            2025/05/09. 09:17    source 
*/ --------------------------------------------------------
*/ add infrastructure for l1p support wide screens
*/ --------------------------------------------------------
*ident l1pwide               drs.    25/04/25.
*deck fovlay5
*i fovlay5.229
 l1pflag  bss    1           1 if l1p
 rightx   bss    1
*d fovlay5.472
          sa3    rightx
*d jb80col.10
          zr     x1,cc       -- use default of (rightx)
*d fovlay5.493
          sa1    rightx
          ix1    x3-x1
*d jb80col.23
          zr     x1,cc       -- use default of (rightx)
*i fovlay5.1331
          sa1    terscrn
          lx1    -1
          mx6    -1
          bx6    -x6*x1
          sa6    l1pflag     1 iff using l1p terminal
          sa1    terscrn
          lx1    -48         get plato current x width 
          mx2    -10
          bx6    -x2*x1
          sa6    rightx
*d fovlay5.2864
          sa1    rightx
          ix1    x3-x1
*d fovlay5.3135
          sa3    rightx
          sx1    xchrinc
          ix3    x3-x1
*d fovlay5.3341
          sa3    rightx
*d fovlay5.3853
          sa3    rightx
*d fovlay5.3964
          sa3    rightx
*i fovlay5.806
*
          sa1    terscrn     test if in word coord mode
          lx1    -8
          mx6    -1
          bx1    -x6*x1
          nz     x1,wcoord   handle  word coord
*
*i fovlay5.882
*
* word coordinate mode sendxy
*
 wcoord   bss    0
          bx6    x5          save x5
          sa6    l1psav2
          mx6    -10         x mask
          bx2    -x6*x3
          sa1    rightx      check bounds
          ix1    x1-x2
          pl     x1,xok1     x ok - in bounds
          sa2    rightx      limit x
 xok1     bss    0
          sendata x2
          mx6    -9          y mask
          bx2    -x6*x4      x2 is y
          sendata x2
          sa2    l1psav2
          bx5    x2          restore x5
          eq     sxy
*
*
*i fovlay5.1484
          mx1    -19
*
*i fovlay5.1498
          mx1    -19
*
*i fovlay5.1513
          mx1    -10
*
* /---   block=09-c wide-tbw19           2025/05/09. 00:18    source 
*/  these relate to using 19 bit masks and shifts rather
*/  than 18 -expand from a 9 bit to 10 bit x
*
*deck platxt
*d platxt.1543
*         next  19     =  margin x(10)/y(9) position
*edit platxt
*deck draws
*d draws.525
          mx0    -19
*deck exec1
*d exec1.1037
          mx0    -19
*d exec1.1744
          mx3    -19
*i exec1.1752
          mx3    -10         x is 10 wide
*i exec1.1753
          mx3    -9          just in case
*i exec1.1601
          mx0    -10
*i exec1.1602
          mx0    -9
*deck exec2
*d exec2.827
          lx0    3+7+19      form altfont bit for size write
*deck grafs
*d grafs.222
          mx0    -19
*d grafs.400
          mx0    -19
*deck tutout
*i tutout.384
*
          mx6    -19
*deck linchr
*d linchr.52
          ax3    3+7+19-8    position -altfont- command bit
*d linchr.243
          mx0    -19
*/
*deck linwrt
*d linwrt.473
          mx0    -19         mask for x/y margin
*/
*deck tutorx
*i tutor1x.1417
          sa1    terscrn
          sx7    1           single bit
          lx7    8           into position
          bx7    -x7*x1      clear wd coord mode flag
          sa7    a1          as we logout
* /---   block=09-d wide-exec1           2025/04/27. 18:24    source 
*deck exec1
*d exec1.1074
          mx0    -10
*i exec1.1030
          mx0    -9
*i exec1.1049
          mx0    -9
*i exec1.1075
          mx0    -9
*i exec1.1085
          mx0    -9
* /---   block=09-e w-simplt             2025/05/04. 08:42    source  out
*deck simplt
*i simplt.46
          ext    txmax
*d simplt.140
          rj     txmax
          ix3    x3+x1
*d simplt.149
          rj     txmax
          sx3    x1-xchrinc
*d simplt.255
 l        rj     txmax
          ix1    x3-x1
*d simplt.459
          rj     txmax
          ix1    x3-x1
*d simplt.488
          rj     txmax
          sx3    x1-xchrinc
*d simplt.797
          mx0    -10
*i simplt.798
          mx0    -9
* /---   block=09-f at cmd               2025/04/27. 21:22    source 
*deck exec1
*d exec1.1029
          mx0    -10
*d exec1.1047
          lx5    1           one more for wide screen
          mx0    -10
*d exec1.1083
          lx5    1           one more for wide screen
          mx0    -10
*deck condc
*d condc.988,condc.993
          mx0    -10
          bx1    x0*x6
          nz     x1,errxytg
          mx0    -9
          bx1    x0*x7
          nz     x1,errxytg
          lx6    60-11
          lx7    60-11-9
* /---   block=09-g -draw-s              2025/05/02. 00:33    source 
*deck fovlay5
*d fovlay5.2626,fovlay5.2628
*               2/1, 18/0, 20/xy, 20/xy    --skip;x,y;x,y
*           or, 40/0, 1/0, 19/xy           --x,y
*           or, 40/0, 1/1, 19/0            --skip
*d fovlay5.2248
*d fovlay5.2253
          lx5    xcodel
*d fovlay5.2258
 sfd2     lx5    xcodel+xcodel
*d fovlay5.2272
 drwpnt1  lx5    xcodel
*i fovlay5.2277
          mx1    -10
*i fovlay5.2288
          mx1    -10
*d fovlay5.2648
          lx5    xcodel      skip/xy to top
*d fovlay5.2651
 drw2     lx5    2*xcodel    skip/xy to top
*deck exec2
*d exec2.126
          mx0    -10
*i exec2.128
          mx0    -9
*i exec2.149
          mx0    -10
*i exec2.176
          mx0    -10
*i exec2.220
 skpmsk   data   40000010000002000000b
*d exec2.243
*
*
 sfdraw1  bss    0           output next set of words
*         need to clear the msb of the 3 parcels
*         and move msb-1 bits up there
          sa3    skpmsk
          bx6    -x3*x6      clear high bit in parcels
          lx3    -1
          bx7    x3*x6       extract msb-1 in parcels
          lx7    1           move then to high bit
          bx6    x6+x7       fixed bits
*
          sa6    mout+x2     output next set of words
*i exec2.264
          mx0    -10
*d exec2.303
          mx7    -10
*i exec2.304
          mx7    -9
*deck draws
*i draws.167
          mx0    -10
*i draws.334
          mx0    -10
*i draws.335
          mx0    -9
*d draws.409
          mx0    -10
*i draws.410
          mx0    -9
*d draws.511
          mx0    -10
*i draws.512
          mx0    -9
*deck covlay2
*d covlay2.1589                      never pack
*                            never pack
* /---   block=10-a -fine-               2025/04/29. 16:19    source 
*deck draws
*i draws.372
          sx2    x1-4        fine command = 4
          zr     x2,finex
*
*i draws.540
*
*
          title  -fine- command execution
*
*
*
*         -fine- command     set x/y screen size
*
 finex    bss    0
 
*         evaluate x and y screen dimensions
*
 fi120    call   get2        evaluate x size, y size
          rj     ztlevel
          zr     x1,proco
          bx1    x7          x1 = value for execerr
          sx0    512
          ix0    x0-x7       y value must be 512
          nz     x0,erxval
          bx1    x6          x1 = value for execerr
          mx0    -10
          bx0    x0*x6       limit x to 10 bits
          nz     x0,erxval
          sx0    x6-8        insure at least one character
          ng     x0,erxval
          bx5    x6          x5 = new x dimension
          lx6    60-12
          lx7    60-12-12
          bx6    x6+x7       x6 = 12/x, 12/y, 36/0
*
*         check if display fits on physical screen
*
          mx7    -1          zreturn = -1 = display fits
          sa7    treturn
          mx0    -12
          sa1    terscrn     get physical screen size
          lx1    36
          bx1    -x0*x1      mask off x screen dimension
          ix1    x1-x5       phys screen - specified size
          pl     x1,fi160    jump if fits on screen
          mx7    0
          sa7    a7          zreturn = 0 = doesnt fit
          eq     proc
*
*
*         set screen size to specified values
*
 fi160    mx0    24
          bx6    x0*x6       12/x,  12/y, 48/0
          sa1    terscrn
          bx1    -x0*x1
          bx6    x1+x6
          sa6    a1
*          sx1    640
          sa1    terscrn
          lx1    -24
          mx2    -10
          bx1    -x2*x1
          ix1    x1-x5
          lx1    -1
          outcode xccode
          eq     proco
*
*
*
*deck comnds
*d yfclnup.9
          jumpov 8lfine,fine,0,cm,twoarg,11010,rorgov,4
* /---   block=10-b lin(r)it             2025/05/09. 15:07    source 
*/
*/        wide screen vector, vbar, hbar
*/
*deck exec3
*d clenup1.61,clenup1.64
          bx2    -x0*x2      y1
          bx4    -x0*x4      y2
          mx0    50
          bx1    -x0*x1      x1
          bx3    -x0*x3      x2
*d clenup1.92
*i clenup1.93
          mx0    -10
          bx3    -x0*x3
* /---   block=10-c pix touch            2025/05/09. 09:26    source 
*ident l1ppix
*deck logicx
*i logicx.1499
          rj     ztlevel
          zr     x1,nol1pz    not l1p
          sa1    key
          lx1    -8
          mx2    -2
          bx1    -x2*x1       source id field
          sx1    x1-1
          nz     x1,nol1pz    not a touch key
*
*                populate cwsinfo with xtouchw x/y
*                for compatability
*
          sa1    xtouchw
          sa2    cwsinfo
          mx0    -20
          bx6    x0*x2       clear  x/y fields
          mx0    -10
          bx2    -x0*x1      x value
          lx2    10          move it up
          bx6    x6+x2
          lx1    -18
          bx2    -x0*x1      y value
          bx6    x6+x2       merge
          sa6    a2          write back
 nol1pz   bss    0
*deck getvar
*d getvar.3488
          rj     ztlevel
          zr     x1,nl1px    not l1p
          sa1    tbtcap
          lx1    59-cp.pixt  pixel enabled bit to sign
          pl     x1,nl1px
*                             if style touch;pixel enabled
          sa1    xtouchw
          mx2    -18
          bx1    -x2*x1
          eq     ttouchx
 nl1px    bss    0
          sa1    key
          lx1    -4
*d getvar.3507
          rj     ztlevel
          zr     x1,nl1py
          sa1    tbtcap
          lx1    59-cp.pixt  pixel enabled bit to sign
          pl     x1,nl1py
*                             if style touch;pixel enabled
          sa1    xtouchw
          lx1    -18
          mx2    -18
          bx1    -x2*x1
          eq     ttouchy
 nl1py    bss    0
          sa1    key
*deck exec7
*i kytfgtx.24
          sa2    tbtcap
          lx2    59-cp.pixt
          ng     x2,dopixt
*i kytfgtx.30
 dopixt   bss    0
*deck toucho
*i toucho.18
          ext    ztlevel
*i toucho.37
          rj     ztlevel
          zr     x1,nol1pz    not l1p
          sa1    key
          lx1    -8
          mx2    -2
          bx1    -x2*x1       source id field
          sx1    x1-1
          nz     x1,process    not a touch key
          sa1    tbtcap
          lx1    59-cp.pixt  pixel enabled bit to sign
          pl     x1,nol1pz    not enabled
          sa1    xtouchw
          mx0    -5          remove lower 5 bits mask
          mx2    -18
          bx6    -x2*x1
          bx6    x0*x6
          sa6    tx
          lx1    -18
          bx6    -x2*x1
          bx6    x0*x6
          sa6    ty
          eq     l1pgo
*
 nol1pz   bss    0
*i toucho.55
 l1pgo    bss    0
