You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

5031 lines
235 KiB

( disk B, side 1)
code receivetable nx ) jsr, ;c ( a ROM array for translating incoming chars)
00000000 , 00000000 , 00000000 , 00000000 , ( 00-07 )
00000009 , 0000000c , 000c000d , 00000000 , ( 08-0f )
00000000 , 00000000 , 00000000 , 00000000 , ( 10-17 )
00000000 , 00000000 , 00000000 , 00000000 , ( 18-1f )
00200021 , 00220023 , 00240025 , 00260027 , ( 20-27 )
00280029 , 002a002b , 002c002d , 002e002f , ( 28-2f )
00300031 , 00320033 , 00340035 , 00360037 , ( 30-37 )
00380039 , 003a003b , 003c003d , 003e003f , ( 38-3f )
00400041 , 00420043 , 00440045 , 00460047 , ( 40-47 )
00480049 , 004a004b , 004c004d , 004e004f , ( 48-4f )
00500051 , 00520053 , 00540055 , 00560057 , ( 50-57 )
00580059 , 005a005b , 005c005d , 005e005f , ( 58-5f )
00600061 , 00620063 , 00640065 , 00660067 , ( 60-67 )
00680069 , 006a006b , 006c006d , 006e006f , ( 68-6f )
00700071 , 00720073 , 00740075 , 00760077 , ( 70-77 )
00780079 , 007a007b , 007c007d , 007e007f , ( 78-7f )
008075c3 , 65c061c2 , 61c361c1 , 00860087 , ( 80-87 )
65c265c3 , 65c169c3 , 69c269c1 , 41c3008f , ( 88-8f )
45c00091 , 00926fc2 , 6fc36fc1 , 75c175c1 , ( 90-97 )
79c34fc3 , 59c3009b , 009c009d , 009e009f , ( 98-9f )
61c069c0 , 6fc075c0 , 6ec64ec6 , 00a600a7 , ( a0-a7 )
00a80020 , 002000ab , 00ac00ad , 00ae00af , ( a8-af )
00000000 , 00000000 , 00000000 , 00000000 , ( b0-b7 )
00000000 , 00000000 , 00000000 , 00000000 , ( b8-bf )
00000000 , 00000000 , 00000000 , 00000000 , ( c0-c7 )
00000000 , 00000000 , 00000000 , 00000000 , ( c8-cf )
00000000 , 00000000 , 00000000 , 00000000 , ( d0-d7 )
00000000 , 00000000 , 00000000 , 00000000 , ( d8-df )
00000085 , 00000000 , 00000000 , 00000000 , ( e0-e7 )
00000000 , 00000000 , 00000000 , 00000000 , ( e8-ef )
00000081 , 00000000 , 00000000 , 00a90000 , ( f0-f7 )
00900000 , 00000000 , 000000a4 , 00000000 , ( f8-ff )
: rnd ( max -- n, where n is between 0 and max )
seed ticks@ + 7abd * 1b0f + ffff and dup seed to * 10 shr ;
: resetphonelight ( -- )
offhook? ( if phone is off hook )
if trained? ( set up correct phonelight)
if valid.psk ( see if 300 or 1200 baud )
if ph1200 else ph300 then
else indphone then ( phone is just off hook )
else " " 0 indicate ( if phone is onhook, turn off light )
then ;
: hangup
" " 0 indicate reset.modem 100 ms onhook
begin rxch? while rxget drop again ;
: connectone ( -- , gives connect tone and sets up explain message )
boop ( carrier found signal )
telconnect xplen to xplint to
%explain curop to ; ( and message )
: sendstring ( addr len -- )
?dup
if 0 do i over + c@ sendchar loop
then drop ;
: matchanswerback ( -- flag )
local pos pos off
answerback swap drop 0= ( see if a message to match )
if -1 exit then ( if not, then anything matches )
begin mticks@ while ( while still have time )
recch? ( if there is a character )
if recget answerback drop pos + c@ = ( and it is next in answerback )
if 1 pos +to answerback swap drop pos = ( then see if done )
if -1 exit then ( if so, really done )
else pos off ( 0 exit) then ( if didn't match, then reset pos )
then
again 0 ; ( if timed out, also no match )
: modemconnect? ( -- true, if connected to internal or external modem )
sendport? dup xmdm = swap imdm = or ;
: setmodem ( flag -- )
xon.reset ( make sure we can transmit )
( initialize mnp in here somehow )
?dup
if trycattocat?
if cattocat? off halfduplex? on answer?
if 200 ms 5 sendchr ( if we are answer modem, send enq after 500 ms)
[ ticks/min 3c / 2* ] literal mticks!
40 ms matchanswerback
if ( cattocat? on)
[ ticks/min 3c / 2* ] literal mticks!
begin mticks@ while
recch?
if recget 5 =
if cattocat? on ( assume it's ctoc only if it asks )
answerback sendstring then
then
again
then
else [ ticks/min 3c / 4 * ] literal mticks!
begin mticks@ while
recch?
if recget 5 =
if answerback sendstring
5 sendchr
[ ticks/min 3c / 2* ] literal mticks!
matchanswerback
if cattocat? on then
then
then
again
then
else cattocat? off then
1 =
if ph300 else ph1200 then ( turn on phone stuff )
connectone ( give connect tone )
-1 trained! ( say that we are trained up )
cattocat? not ( if we're not cat-to-cat )
if begin recch? while recget drop again then ( clean up the buffer )
else hangup then ;
: trainanswer ( time -- f, f=0:connect fail, f=1:300 baud, f=2:1200 baud )
local timeleft timeleft to
[ ticks/min 3c / ] literal 2* dup negate timeleft +to train.orig
dup 0=
if begin
drop ( clean up result from train.orig )
[ ticks/min 3c / ] literal dup 2* rnd swap 3 * + timeleft min
dup negate timeleft +to train.ans
dup 0= timeleft and ?panic not and while drop ( clean up train.ans )
[ ticks/min 3c / ] literal dup 2* rnd swap 3 * + timeleft min
dup negate timeleft +to train.orig
dup timeleft 0= or ?panic or
until
then ;
code tst.highspeed ( -- flag )
duart #n a0 .l move, ( get base of duart )
a0 ser.ip )d d0 .b move, ( get flag register )
01 #n d0 .b and, ( see if highspeed is set, bit 0 )
eq if, -1 #n d0 moveq, else, 0 #n d0 moveq, then,
d0 sp -) move,
next;
: trainexternal ( time -- f, f=0:connect fail, f=1:300 baud, f=2:1200 baud )
mticks! ( wait for this long )
begin tst.dcd mticks@ 0= or ?panic or until ( until carrier, key, time out )
tst.dcd ( if we have a carrier )
if tst.highspeed ( see if 1200 baud )
if 2 else 1 then ( return appropriate connected flag )
else 0 then ; ( else didn't make it )
: savedigit ( char -- )
hold ;
: externaldial ( addr len -- )
local pulse? pulse? off ( assume we aren't pulse dialing )
xon.reset ( make sure we can transmit )
?dup ( see if anything to dial )
if " AT" sendstring 0d sendchar ( make sure of speed to modem )
modemdefault$ sendstring 0d sendchar ( send the nonchanging sequence )
modeminit$ sendstring 0d sendchar ( and now the changable stuff )
" ATDT" sendstring ( send initial dial string )
0 swap 1- ( scan the string backwards )
do
i over + c@ ( get the next byte )
dup 80 and pulse? xor ( see if there's a transition )
if dup 80 and ( see which we are going towards )
if ascii P sendchar else ascii T sendchar then ( send appr. char)
then
7f and sendchar ( now just send the character )
?panic 0= while
-1 +loop ( and on to the next one )
0d sendchar ( when all done, send a return )
then drop ; ( else clean up the stack )
: waitdialtone ( -- )
7d0 ms ; ( for now, just wait 2 seconds )
: Phone
modemconnect? not ( if not hooked to internal modem )
if nomodem error collapse widecursor exit then ( give message )
?extended ( if there is an extended selection )
if trained? if nodial error collapse widecursor exit then
phdial rule ( say we have the phone off hook )
offhook? not ( see if off hook yet )
if offhook mute ( so make sure phone is off )
waitdialtone ( check for a dial tone here )
then
<# ( hold the phone number here in the pad)
bos ( starting at the beginning )
begin
dup gap < ?panic 0= and while ( while we are still in the sel )
[ $uln 1 shr &attr or ] literal ( this is the underline attrib )
over attribute over and = ( if the character is underlined )
if dup c@ ( get the character )
dup ascii 0 ascii 9 inrange ( if it is a digit )
if dup 80 or savedigit ( high bit indicates pulse dial )
sendport? xmdm =
if drop ( if an external modem, do nothing yet )
else char>pulses then ( then pulse dial the number )
else drop then ( otherwise clean up the stack )
else dup c@ ( get the character )
dup ascii 0 ascii 9 inrange ( if it is a digit )
over ascii * = or ( or a * )
over ascii # = or ( or a # )
if dup savedigit
sendport? xmdm =
if drop ( if external modem, do nothing yet )
else char>tone then ( then tone dial the number )
else drop then ( or clean up the stack )
then
dup c@ ascii , = ( if the character was a comma )
if sendport? xmdm <>
if 1f4 ms then ( if not external modem, )
ascii , savedigit then ( wait half a second and save wait )
nextchar ( on to the next character )
again drop
0 #> lastphone "to ( and store string away )
sendport? xmdm =
if lastphone externaldial then ( finally dial external)
talk ( unmute the phone after dialing )
collapse widecursor ( fix up the selection )
indphone ( just waiting for the carrier )
-1 enablecpm! initcpmstatus ( enable call progress monitoring )
[ ticks/min 3c / ] literal 2* cpmcount! ( set switching counter )
carriertimeout [ ticks/min 3c / ] literal *
mticks! ( let phonetest wait for some seconds )
else offhook? ( if not extended, then see if off hook)
if ( mnp? if indicate disconnect)
cattocat? trained? and ( if we are talking to another Cat )
if xon.reset ( make sure we can transmit )
6 0 do 3 sendchar loop then ( send ETX to cause other end to hangup)
200 ms ( allow chars to get to other end )
hangup ( if so, hang up the phone )
else begin ringstate until ( wait for phone to stop ringing )
offhook ( else pick up the phone )
phwait rule ( turn on phone indicator )
5dc ms ( wait 1.5 seconds *** )
sendport? xmdm = ( if connected to external modem )
if xon.reset ( make sure we can transmit )
" AT" sendstring 0d sendchar ( make sure of speed )
modemdefault$ sendstring 0d sendchar ( init w. unchanging stuff )
modeminit$ sendstring 0d sendchar ( initialize modem )
" ATA" sendstring 0d sendchar ( force modem to answer phone )
carriertimeout [ ticks/min 3c / ] literal * trainexternal
else carriertimeout ( and try to get a connection )
[ ticks/min 3c / ] literal * trainanswer
then
setmodem ( set indicators as needed )
then
then auto-answer? off ; ( we certainly didn't auto answer )
: Redial ( -- )
modemconnect? not ( if we aren't using a modem )
if nomodem error exit then ( you can't dial the phone )
trained? if nodial error exit then ( we can't dial if we are connected )
offhook? if hangup 7d0 ms then ( if waiting, hang up for 2 seconds )
lastphone ?dup ( see if any phone number )
if offhook mute waitdialtone ( if so, take phone off hook )
phdial rule ( and put up phone light )
sendport? xmdm =
if externaldial 0 ( dial the number, and leave a # )
else 0 swap 1- ( for length of string, backwards )
do i over + c@ ( get the digit )
dup ascii , = ( if it is a comma, wait )
if drop 1f4 ms ( for 1/2 second )
else dup 80 and ( else, see if we should pulse dial )
if 7f and char>pulses ( if so, tap away )
else char>tone ( else tone dial the number )
then
then
?panic 0= while ( if panic out )
-1 +loop
then
talk ( unmute phone after dialing )
indphone ( put up the indicator )
carriertimeout [ ticks/min 3c / ] literal * ( and set the timeout )
mticks!
auto-answer? off ( we haven't auto-answered )
then drop ; ( left over string address )
: do-cmd ( key -- )
stripshifts dup ff00 and ff00 <> ( not a control key? )
if dup curop to then ( if so, save key as current event )
ff80 and ff80 <> ( not a key going up? )
if scancode ?shift if 40 or then ( get scancode and also shifted )
2* cmds + w@ execute ( use scancode for key to do event )
cursor? if resetcursor then ( just to make sure ruler is ok )
then ?stackerr ; ( and check for a stack error )
: setuf ufpressed? on ; ( sets flag for use-front going down )
: ?blinks bticks@ 0= if blink then ;
: ?voff ( -- )
vticks@ 0= ( if video has timed out )
if dirtytext? emptytext? not and ( if text is dirty and not empty )
if compress ( first, get all the redundant space back )
<Disk> dirtytext? not ( if after the disk, we are now clean )
a0 @ptr 0= and ( and we exited after a save, not restore )
if screen-save ( turn off and wait for a key )
else reset-vticks ( else, reset video counter )
then
else screen-save ( turn off and wait for a key )
then
then ; ( when get one, turn video back on )
: defaultmsg ( -- addr len )
" QWERASDFZXCV" ( pattern required )
dup patlen = rot rot pattern swap same? and ( if special marker)
if #defmsg 1+ 2* msgtbl + w@ ?dup ( get next token )
if execute ( if not null, execute )
4 down? 5 down? and ( if both down )
if 1 #defmsg +to then ( make permanent )
else msgtbl w@ execute ( else get start of tbl)
4 down? 5 down? and ( if both down )
if #defmsg off then ( make permanent )
then
else #defmsg 2* msgtbl + w@ execute then ; ( else get current msg )
: checkcpm ( -- flag, 0=no change, 1=busy, 2=ring )
cpmhstatus@ 2 < cpmlstatus@ 2 < or not ( if either is too short, skip )
cpmhstatus@ cpmlstatus@ + 8 > and ( and total time is long enough)
if cpmhstatus@ cpmlstatus@ + 9 < ( ***then check total cadence )
if 1 else 2 then ( and return ring or busy )
else 0 then ; ( not enough info, no change )
: phonetest
offhook?
if trained?
if carrier? 0=
if reset.modem 100 ms ( reset the modem )
begin recch? while recget drop again ( flush receive buffer )
4 [ ticks/min 3c / ] literal * mticks! ( prepare to wait 4 sec)
carrierlost error ( sound that carrier was lost )
indphone rule then ( and turn off the indicator )
else mticks@ 0=
if hangup rule
auto-answer? ( if we had auto-answered )
if bot op to ( make us select EVERYTHING )
extend <Disk> then ( then select whatever and try to Disk )
else cpmcount@ 0= ( see if counter has run out )
if enablecpm? 0= enablecpm! ( if so, switch cpm/carrier detect )
[ ticks/min 3c / ] literal 2* cpmcount! ( and reset counter )
else enablecpm? ( if checking call progress )
if checkcpm ?dup ( see if we have a status )
if 1 = ( see which to indicate )
if phbusy else phring then ( and set indicator )
rule ( in the ruler )
then
( <# cpmhstatus@ # # ( nothing else, show call progress **)
( drop cpmlstatus@ # # #> ( for now, just show counts in ruler)
( phonelight rule )
else sendport? xmdm = ( else, if checking for carrier )
if tst.dcd else valid.fsk.orig then
if 0 enablecpm! filter.high ( turn off call progress monitor)
phwait rule
carriertimeout [ ticks/min 3c / ] literal *
sendport? xmdm =
if trainexternal else train.orig then
setmodem rule
then
then
then
then
then
else rings@ 0= ( if we've counted enough rings )
modemconnect? and ( and connected to a modem )
gap 5 + dpktsize + bou < dirtytext? not or and ( we're not out of room)
if begin ringstate until ( wait for phone to stop ringing )
von ( turn on the display first )
offhook phwait rule 5dc ms ( wait 1.5 seconds before carrier *** )
sendport? xmdm =
if xon.reset ( make sure we can transmit )
" AT" sendstring 0d sendchar ( initialize modem first )
modemdefault$ sendstring 0d sendchar
modeminit$ sendstring 0d sendchar
" ATA" sendstring 0d sendchar
then
carriertimeout [ ticks/min 3c / ] literal *
sendport? xmdm =
if trainexternal else train.ans then
dup ( see if got a connect )
if dirtytext? not ( if text is clean )
if cursoroff initedde ( then we can start fresh )
redisplay resetcursor checkline# checkgauge checkbattery
phwait rule cursoron ( and reshow the cold text )
else emptytext?
if cleanedde
else cursoroff
gap 5 + dpktsize + bou < ( if room for a doc char )
if gap 5 + makedefdpkt ( insert a document to separate)
forceop on gap 5 + dpktsize insertblock
forceop on ['] unreceive undop to ( make us continue op )
gap prevchar bos to redisplay widecursor cursoron
then
then
then auto-answer? on ( we did an auto-answer )
then
setmodem rule
then
then ;
( create the eventlist, that contains things to be done in <equit> loop )
code eventlist nx ) jsr, ;c ( create ROM array )
t' ?blinks w,
t' ?voff w,
t' phonetest w,
0000 w, ( flag indicating no more )
: periodicevents ( -- ,modified so that stack errors won't kill us )
local eventptr ( pointer into the event list )
eventlist eventptr to ( the address of the list )
begin eventptr w@ ( get first item from list )
?dup while ( if it isn't the end )
execute 2 eventptr +to ( then execute it and go onto the next )
again ;
( tlh 5/20:7:51 )
: movetext ( source destination len -- ,moves text to and from undo buffer )
local len local dest local source local oldgap
len to dest to source to gap oldgap to
len 0= if exit then ( if nothing to do, do nothing )
source bos = dest bou = and source bou = dest gap = and or not
if len enoughtext outofroom then ( if not bos<=>bou check room )
dest gap > ( dest in upper text, move buffer and text out of the way )
if bou bou len - dest bou - move
bou dest bou 1+ max len negate realign
dest beot = if len negate beot +to then len negate dest +to
else len gap +to
then
source dest len move ( move the text )
source oldgap > ( if source in upper text, pull it out now )
if bou bou len + source bou - move bou source bou 1+ max len realign
source beot = if len beot +to then
else len negate gap +to
then preset ;
( tlh 3/01:23:17 )
: trimselection ( -- flag ,false if two ds's only chars in region )
bor nextchar nextchar eor = if 0 exit then ( void text )
bos bor > not if bor nextchar bos to then ( first ds may not change )
eos eor < not
if eos prevchar eos to ( nor may last ds in region)
movegap bos gap < not if eos bos to then
then -1 ( flag=success ) ;
( tlh 7/8:10:48 )
code findcalc sp )+ d0 move, sp )+ a0 move, ef 100 - #n d2 moveq,
6 #n d1 moveq, ( minimum packet size ) sp -) clr, ( assume no pkt )
begin, d1 a0 add, d0 a0 cmp, cs
while, a0 ) d2 .b cmp, cs ( > f0 could be packet byte )
if, a0 a1 move, d1 a1 sub, &calc 100 - #n d2 moveq,
begin, a1 )+ d2 .b cmp, eq ( found packet leader byte )
if, 1 #n a1 subq, a1 sp ) move, next, then, a0 a1 cmp, eq
until, ( some other kind of packet ) ef 100 - #n d2 moveq,
then,
again, next;
( tlh 7:20:10:30 )
: aftererase
bos fmtchrs if prevbrk then inwindow
if dup loadline gapline over 1+ max swap
do i storeline wrap putivl drop i update! loop
gap beot killivls
else gapline off then redisplay ;
( tlh 7/8:15:05 )
: restoreselection ( -- | undo of removeselection ) fmtchrs on
gap prevchar op to ( remember beginning of area )
ubufsize bou gap ubufsize move dup gap +to bou +to
op nextchar op to ( now beginning of restored area )
workpkt @ ( see if there is a held packet )
if op prevbrk dup fpkt? ( if there is a packet on prev break )
if workpkt 1- swap copypkt ( then just copy it into place)
else drop syserror error then ( if not, something is wrong! )
then
clearundo ( and make sure buffer is empty )
workpkt pktsize 0 fill ( and clear out workpkt too )
op
begin gap findcalc dup
while dup unlinkcalc 0= if syserror error then 1+
again drop op prevbrk beot killivls ( and clean up when done )
beot partknown op bos to selected ( make an extended selection )
aftererase extendedcursor ( and leave the selection extended )
['] removeselection undop to dirtytext? on ;
( tlh 7/8:15:06 )
: <removeselection> ( -- )
fmtchrs off
selsize 1 < ( if no text in selection )
if eos eot prevchar < ( but there is more text left )
if eos nextchar eos to movegap ( then must be on bot )
eos prevchar bos to ( so set to narrow just after it )
redisplay narrowcursor -1 exit ( flag that should really exit)
else gap prevchar bos to ( nothing at all in the text )
redisplay widecursor -1 exit ( flag that should really exit )
then
then
0 ( we are successful, now can erase )
bos begin gap findcalc dup while dup linkcalc 6 + again drop
bos gap pktbytes dup fmtchrs to 0=
if bos beot killivls beot partknown exit then ( no packet here, done )
gap begin prevbrk dup fpkt? until ( address of last packet in selection)
bos prevbrk dup fpkt? ( if packet, does prevbrk have pkt? )
if dup workpkt 1- copypkt copypkt ( if so, save it in packet buf )
else bos findchar workpkt makepkt ( if no pkt, fmt in temp)
brk+ pktsize makespace ( make space for new packet )
swap pktsize + swap 1- copypkt ( and move it there )
then bos prevbrk beot killivls beot partknown ;
( tlh 6/6:11:00 )
: removeselection ( -- )
<removeselection> if exit then ( do other part first )
selsize negate bou +to bos bou selsize move bos gap to
gap prevchar dup bos to cpos to ( and reset selection start )
aftererase widecursor ( and show reshow the display )
op gap prevchar 1+ beot 1- inrange if bos op to then
pop gap prevchar 1+ beot 1- inrange if bos pop to then
['] restoreselection undop to ( finally, set how to undo this )
dirtytext? on ;
( tlh 7/8:15:07 )
: gobble ( -- ) fmtchrs off
selsize 1 < ( must be at eot, so reverse )
if eos prevchar bos to redisplay widecursor exit then
bos gap pktbytes dup fmtchrs to ( are we about to gobble a format )
if workpkt @ 0= if bos findchar workpkt makepkt then
bos prevbrk dup fpkt? 0= if brk+ pktsize makespace 1- then bos swap copypkt
then
bos begin gap findcalc dup while dup linkcalc 6 + again drop
bos beot killivls beot partknown
bos eou selsize movetext ( move to end of the undo buffer )
beot dup nextchar over - gap swap movetext ( next char as sel )
gap prevchar bos to beot eos to ( set up selection )
aftererase narrowcursor ( and leave the selection narrow )
op gap prevchar 1+ beot 1- inrange if bos op to then
pop gap prevchar 1+ beot 1- inrange if bos pop to then
['] ungobble undop to ; ( this is how to undo gobble )
( tlh 7/8:15:08 )
: ungobble ( -- ) fmtchrs on
workpkt @ ( was a break deleted? )
if bos prevbrk dup fpkt? ( if previous break has a packet )
if workpkt 1- swap copypkt ( copy held pkt into place )
else drop then ( else we don't need to do anything )
then
bou
begin eou findcalc dup
while dup unlinkcalc 0= if syserror error then 6 +
again drop ( and clean up when done )
bos beot killivls beot partknown
gap prevchar dup gap swap - beot swap movetext
bou gap ( get one char from ubuf before gap )
eou prevchar bou = if ubufsize else bou nextchar bou - then movetext
bou bou 4 + ubufsize move ( move rest to beot )
beot op to ( remember where beot was located )
bou 4 + beot to ( set beot now )
preset beot eos to gap prevchar bos to ( set areas )
clearundo
aftererase narrowcursor ( leave cursor selected )
['] regobble undop to dirtytext? on ; ( and here's how to redo gobble)
( tlh 7/8:15:08 )
: regobble ( -- )
bos gap pktbytes dup fmtchrs to
if bos findchar workpkt makepkt bos bos prevbrk copypkt then
bos begin gap findcalc dup while dup linkcalc 6 + again drop
beot begin op findcalc dup while dup linkcalc 6 + again drop
bos op killivls op partknown
selsize negate bou +to bos bou selsize move bos gap to ( get 1st char )
beot eou op beot - move op beot to ( then rest of old selection )
beot dup nextchar over - gap swap movetext ( next char as sel )
beot eos to gap prevchar bos to ( set up selection, etc )
aftererase narrowcursor ( and display it )
['] ungobble undop to dirtytext? on ;
( tlh 6/6:10:48 )
: Erase ( -- ) %erase curop to ( distinguish from undo )
trimselection 0= if exit then ( make sure selection is within text )
?extended if lockedsel
else bos lockedtext?
if selsize 1 < ( if the selection is too small )
if eos eor prevchar < ( but there is more text left )
if eos nextchar eos to movegap ( then must be on bot )
eos prevchar bos to ( so set to narrow just after it )
redisplay narrowcursor ( flag that should really exit)
else gap prevchar bos to ( nothing at all in the text )
redisplay widecursor ( flag that should really exit )
then
exit
else lockedtext error exit
then
then
then
curop lastop <> ( new erase, save state and prepare empty packet )
if clearundo savepos workpkt pktsize 0 fill then
dirtytext? on ( make the text dirty now )
narrowcursor? ( which type of erasure to perform?)
if gobble else removeselection then
op gap prevchar 1+ beot 1- inrange if bos op to then
pop gap prevchar 1+ beot 1- inrange if bos pop to then ;
code maxundo i' beot d0 move, i' gap d0 sub, 8 #n d0 subq,
d0 sp -) move, next;
( tlh 5/28:2:45 )
: cformat1 dirtytext? on
eou selsize - bou to
bos bou selsize move ( save selection ) ;
( tlh 7/8:12:43 )
: cformat2 local bosline local eosline
bos beot killivls
gap to preset
bos inwindow 0= if 0 then bosline to eos inwindow if eosline to then
topline bosline + findline eosline 1+ bosline
do i storeline putivl drop wrap i update! loop
op bos min bos to selected gap prevchar bos to refresh
oldcstate cstate to narrowcursor? if narrowcursor else widecursor then ;
( tlh 3/24:12:22 )
: cformat3
ubufsize needtext
if op op ubufsize + gap op - move ( move selection out of way )
bou op ubufsize move ( move in undo buffer )
op ubufsize + eou gap op - - gap op - move ( save sel )
else drop ( if not enough room )
op gap over - reverse ( triple reverso time! )
bou eou over - reverse
op eou over - reverse
then
op ubufsize + ( this will be the gap - for cformat2 )
eou gap op - - bou to ( save old selection )
op bos to ( make a pseudo-selection )
op beot killivls
cformat2 ;
: Uncformat ( -- ) cformat3 ['] Uncformat undop to ;
: Bold ( -- ) ( tlh 6/4:8:16 )
local extrasize savepos extend lockedsel
undop ['] Uncformat <> ubufsize 0= or ufpressed? or
if clearundo selsize needtext outofroom cformat1 then ufpressed? off
bos selsize $bold attribregion curop lastop <> learnbuff and or
if selsize bos selsize extramods dup extrasize to
+ 5 + needtext outofroom
bos gap extrasize + 5 + selsize move
gap extrasize + 5 + bos selsize $bold movewith
else selsize 5 + needtext outofroom
bos gap 5 + selsize move
gap 5 + bos selsize $bold movenotwith
then cformat2 ['] Uncformat undop to ;
: Under ( -- ) ( tlh 6/4:8:17 )
local extrasize savepos extend lockedsel
undop ['] Uncformat <> ubufsize 0= or ufpressed? or
if clearundo selsize needtext outofroom cformat1 then ufpressed? off
bos selsize $uln attribregion curop lastop <> learnbuff and or
if selsize bos selsize extramods dup extrasize to
+ 5 + needtext outofroom
bos gap extrasize + 5 + selsize move
gap extrasize + 5 + bos selsize $uln movewith
else selsize 5 + needtext outofroom
bos gap 5 + selsize move
gap 5 + bos selsize $uln movenotwith
then cformat2 ['] Uncformat undop to ;
: Caps ( -- ) ( tlh 6/4:8:19 )
savepos extend lockedsel
undop ['] Uncformat <> ubufsize 0= or ufpressed? or
if clearundo selsize needtext outofroom cformat1 then ufpressed? off
bos selsize capregion curop lastop <> learnbuff and or
if bos selsize uppercase else bos selsize lowercase then
gap cformat2 ['] Uncformat undop to ;
( 6/5:16:28 )
( flag --- ,-1 fails, prepare formats by emplacing state fore and aft)
: pformat1
badivl if beot max eot 1+ killivls then ( ** protect ivls during learn)
pktsize 2* maxundo > if -1 noroom error exit then
workpkt makepkt ( save current state in packeted style )
eos prevchar inwindow if eosline to then ( same if sel overflows screen)
bos narrowcursor? 0= if nextchar then prevbrk brk+ prepkt to
beot prevchar widecursor? 0= if prevchar then nextbrk brk+ postpkt to
postpkt c@ &fmt <> ( packet needed to propagate state beyond sel )
if postpkt prevchar findchar postpkt pktsize makespace postpkt to
postpkt makepkt preset
then
prepkt c@ &fmt <> ( first packet propagating state at start of selection)
if prepkt prevchar findchar ( get state presently implied )
prepkt pktsize makespace makepkt preset
postpkt beot < if pktsize postpkt +to then
then beot eos to 0 ;
( tlh 12/16:14:55 )
: pformat2 local operation operation to
prepkt postpkt beot max killivls ( selection and overlap areas altered)
postpkt beot max partknown ( rest may resolve )
prepkt prevchar
begin gap postpkt prevchar min firstbreak ?dup
while brk+ dup c@ &fmt = ( modify found packets )
if dup getpkt operation execute dup makepkt then
again
prepkt prevchar inwindow ( try to keep effected area on screen )
if dup loadline lastline 1+ swap
do i storeline wrap i update! putivl drop loop ( compute rest of window )
bos visible?
if eos prevchar inwindow ( display if entirely in window array )
if lastseen 1- > if new-display then refresh
else new-display then
else new-display then
else new-display
then gap 1- inwindow if gapline to then
dirtytext? on eos prevchar bos <>
if cstate bos gap prevchar dup bos to cpos to narrowcursor bos to cstate to
else resetcursor then fixcursor ;
( tlh 6/5:17:22 )
: unformat swappkts prepkt postpkt beot max dup partknown killivls
oldbos bos oldbos to bos to oldcstate cstate oldcstate to cstate to
eos prevchar inwindow
eosline firstseen - eos-display if eosline to then
resetcursor ;
( 6/26:2:39 )
: reform
pformat1 if drop exit then
ufpressed? lastop %seti <> lastop %sett <> and lastop %setl <> and
lastop %sets <> and lastop %setj <> and lastop %setr <> and or
if bos gap pktbytes pktsize 2* 2* + dup maxundo >
if 2drop noroom error exit then eou swap - bou to savepkts savepos
then ufpressed? off
pformat2 ['] unformat undop to rule
begin ?ctl while begin fixivl <?k> until ?ctl
while ?kval shiftkey? if <key> drop else leave then
again
cursor? off
scancode 38 = scancode 32 = or scancode 2 = or scancode 0b = or
scancode 29 = or scancode 31 = or 0= ?ctl 0= or
if cursor? on bos eos prevchar <>
if collapse narrowcursor else resetcursor then then
fixcursor ;
( tlh 7/20:15:51 )
code findds sp )+ d0 move, sp )+ a0 move, ef 100 - #n d2 moveq,
dpktsize 1- #n d1 moveq, sp -) clr, d0 a0 cmp, nc if, next, then,
begin, d1 a0 add, d0 a0 cmp, cs
while, a0 ) d2 .b cmp, cs ( > f0 could be packet byte )
if, a0 a1 move, d1 a1 sub, ds #n d2 moveq,
begin, a1 )+ d2 .b cmp, eq ( found packet leader byte )
if, 1 #n a1 subq, a1 sp ) move, next, then, a0 a1 cmp, eq
until, ( some other kind of packet ) ef 100 - #n d2 moveq,
then,
again, next;
( tlh 7/20:15:48 place document controls into all documents in selection )
: redoc bos narrowcursor? 0= if nextchar gap min then ds prevmatch prepkt to
gap widecursor? 0= if prevchar then postpkt to prepkt
begin postpkt findds ?dup
while dirtytext? on dup getdpkt getdocpak dup makedpkt 1+
again beot partknown prepkt beot killivls
undop off rewindow refresh ;
( tlh 3/11:10:02 )
code samepkt? sp )+ a0 move, sp )+ a1 move, pktsize 1- #n d1 moveq,
begin, a0 )+ a1 )+ .b cmpm, ne if, sp -) clr, next, then, d1 nt -until,
-1 #n d0 moveq, d0 sp -) move, next;
( tlh 8/27:12:24 )
code findpkt sp )+ d0 move, sp )+ a0 move, ef 100 - #n d2 moveq,
pktsize 1- #n d1 moveq, sp -) clr,
begin, d1 a0 add, d0 a0 cmp, cs
while, a0 ) d2 .b cmp, cs ( > f0 could be packet byte )
if, a0 a1 move, d1 a1 sub, &fmt 100 - #n d2 moveq,
begin, a1 )+ d2 .b cmp, eq ( found packet leader byte )
if, 1 #n a1 subq, a1 sp ) move, next, then, a0 a1 cmp, eq
until, ( some other kind of packet ) ef 100 - #n d2 moveq,
then,
again, next;
( tlh 8/27:12:24 )
: compress local p1 local p2 local p3 local adto local adfrom
text gap findpkt dup p1 to
if p1 1+ gap findpkt dup p2 to p2 adto to
if begin p2 1+ gap findpkt dup p3 to 0= if gap p3 to then
p2 p1 p2 samepkt? if pktsize + else adto p1 to then adfrom to
adfrom adto p3 adfrom - move
adfrom p3 adto adfrom - realign
p3 adfrom - adto +to p3 p2 to gap p3 =
until adto gap to
then
then
beot eot findpkt dup p1 to
if p1 1+ eot findpkt dup p2 to p2 adto to
if begin p2 1+ eot findpkt dup p3 to 0= if eot p3 to then
p2 p1 p2 samepkt? if pktsize + else adto p1 to then adfrom to
adfrom adto p3 adfrom - move
adfrom p3 adto adfrom - realign
p3 adfrom - adto +to p3 p2 to eot p3 =
until
bou bou eot adto - + adto bou - move
bou adto eot adto - realign
then
then preset ;
( tabpos --- tabpos type -or- 0 ,returns next tab pos, type=1/-1=n/d )
code nextab #tabs #n a0 move, sp )+ d0 move, ( d0=tab pos sought )
d0 d1 move, d1 d2 move, 3 #n d2 .w lsr, 7 #n d1 .w and, d2 a0 add,
begin, a0 )+ d2 .b move,
begin, d1 d2 btst, ne
if, d0 sp -) move, -1 #n d0 moveq, d1 a0 9 )d .b btst, eq
if, 1 #n d0 moveq, then, d0 sp -) move, next,
then, 1 #n d0 .w addq, 1 #n d1 .w addq, 7 #n d1 .w and, eq
until, #tabs 0a + #n a0 cmp, nc
until, sp -) clr, next;
( tabpos flag --- , 1/-1 =normal/decimal type tab setting )
code addtab #tabs #n a0 move, sp )+ d3 move, sp )+ d1 move,
d1 d2 move, 3 #n d2 .w lsr, 7 #n d1 .w and,
d1 a0 d2 0 xw)d .b bset, d3 .w tst, mi
if, d1 a0 d2 0a xw)d .b bset, else, d1 a0 d2 0a xw)d .b bclr, then,
next;
( tabpos --- ,delete tab from array )
code deltab #tabs #n a0 move, sp )+ d1 move,
d1 d2 move, 3 #n d2 .w lsr, 7 #n d1 .w and, d1 a0 d2 0 xw)d .b bclr, next;
( tlh 3/26:18:15 )
: repos local dif local right #left c@ #indent c@ - dif to posit to
#left c@ #wide c@ + right to curop %setl =
if posit 2- 2* #left c! right #left c@ - #wide c!
#left c@ dif - lbound 2- 2* max rbound 2- 2* min #indent c!
right #indent c@ - #iwide c!
then
curop %seti =
if posit 2- 2* #indent c! right #indent c@ - #iwide c! then
curop %setr =
if posit 2- 2* #left c@ - #wide c!
#left c@ #wide c@ + #indent c@ - 2 max #iwide c!
then
unvtline rule posit
curop %setr = if 1- then vtline ( don't ask ) ;
: initset iposit to rbound to lbound to
0 [ vtbuff ] literal ! iposit repos initkey ;
: marginloop
begin ?ctl
while getkey
while ?rex ( right ) if posit 1+ rbound min repos then
?lex ( left ) if posit 1- lbound max repos then
again unvtline ;
( tlh 5/10:11:04 )
: tabloop local flag flag off
begin ?ctl
while getkey
while ?rex ( right ) if posit 1+ 51 min repos flag on then
?lex ( left ) if posit 1- 3 max repos flag on then
thiskey 09 = thiskey 93 = or ( tab set/clear )
if posit 2- dup nextab if = else drop 0 then
if posit 2- nextab 0< flag or
if deltab else -1 addtab then
else posit 2- 1 addtab
then rule flag off
then
thiskey 20 = ( space )
if posit 1- nextab 0= if 1 then 2+ repos flag on then
thiskey e0 = ( erase ) if #tabs tabcount 0 fill rule then
again unvtline ;
: fixindent ( -- | )
local right #left c@ #wide c@ + right to
##ctrl %indent + c@ dup right 3 - > if drop 1 beepflag +to exit then
#indent c! right #indent c@ - #iwide c! ;
( tlh 3/19:18:04 )
: fixleft ( -- | )
local right fixindent #left c@ #wide c@ + right to
##ctrl %left + c@ dup right 3 - > if drop 1 beepflag +to exit then
#left c! right #left c@ - #wide c! ;
: fixright ( -- | )
local right ##ctrl %wide + c@ right to
#left c@ right 3 - > if 1 beepflag +to exit then
#indent c@ right 3 - > if 1 beepflag +to exit then
right #left c@ - #wide c! right #indent c@ - #iwide c! ;
: fixtabs ##ctrl %tabs + #tabs tabcount move ;
: fixspacing ##ctrl %lsp + c@ #lsp c! ;
: fixjustify ##ctrl %just + c@ #just c! ;
( tlh 5/23:23:42 )
: preform
lockedsel beot widecursor? 0= if prevchar then findchar
ufpressed? lastop %seti <> lastop %sett <> and lastop %setl <> and
lastop %sets <> and lastop %setj <> and lastop %setr <> and or
if clearundo then ;
( tlh 6/12:12:11 )
: Spacing preform %sets curop to
lastop curop <> learnbuff and ( always 1.5 first learn )
if 2
else #lsp c@ 1+ dup 4 = if 3 - then
then
##ctrl %lsp + c! ['] fixspacing reform ;
( tlh 6/12:12:16 )
: Justify preform %setj curop to
lastop curop <> learnbuff and ( always center first learn )
if 2
else #just c@ 2+ dup 4 = if drop 1 then dup 5 = if drop 0 then
then ##ctrl %just + c! ['] fixjustify reform ;
( tlh 6/28:12:56 )
: Defleft preform %setl curop to
#defaults %indent + c@ ##ctrl %indent + c!
#defaults %left + c@ ##ctrl %left + c! ['] fixleft reform ;
( tlh 6/12:14:47 )
: Left preform %setl curop to
2 #left c@ #wide c@ + 2/ #left c@ 2/ 2+ initset marginloop
#indent c@ ##ctrl %indent + c! #left c@ ##ctrl %left + c!
['] fixleft reform ;
( tlh 6/12:14:48 )
: Defindent preform %seti curop to
#defaults %indent + c@ ##ctrl %indent + c! ['] fixindent reform ;
( tlh 6/12:14:48 )
: Indent preform %seti curop to
2 #left c@ #wide c@ + 2/ #indent c@ 2/ 2+ initset marginloop
#indent c@ ##ctrl %indent + c! ['] fixindent reform ;
( tlh 6/12:14:48 )
: Defright preform %setr curop to
#defaults %left + c@ #defaults %wide + c@ + ##ctrl %wide + c!
['] fixright reform ;
( tlh 6/12:14:48 )
: Right preform %setr curop to
#indent c@ #left c@ max 2/ 4 + &horiz 2/ 2+
#left c@ #wide c@ + 2/ 2+ initset marginloop
posit 2* 4 - ##ctrl %wide + c! ['] fixright reform ;
( tlh 6/12:14:48 )
: Deftabs preform %sett curop to
#defaults %tabs + ##ctrl %tabs + tabcount move ['] fixtabs reform ;
( tlh 6/12:14:49 )
: Tabs preform %sett curop to
0 0 cx 2/ 3 max 51 min initset tabloop
#tabs ##ctrl %tabs + tabcount move ['] fixtabs reform ;
: undoclock ( -- )
local startrange local endrange
local lockdoc? lockdoc? off ( assume will unlock the doc )
local ptr eou 1- ptr to ( scan backwards down the buffer )
bos ( start finding the beginning of range )
?extended if nextchar then ( special case for extended )
prevdoc startrange to ( start of range to set )
eos prevchar prevchar nextdoc endrange to ( end of range to set )
widecursor? bos c@ ds = and ( a special case if wide on a ds )
if bos startrange to
eos prevchar nextdoc endrange to
then
startrange
begin
endrange nextdsorcalc ( find next break or calc )
dup endrange < while ( see if still in range )
dup c@ fe and &calc = ( see if a calc or lockcalc token )
if lockdoc? if &lockedcalc else &calc then ( locking or not? )
over c! ( and set the token )
else dup c@ ds = ( see if a document token )
if ptr c@ lok = lockdoc? to ( find out what to do to this doc )
dup getdpkt
#lock c@ ptr c! -1 ptr +to ( save old state of document)
lockdoc? if lok else markbl then #lock c! ( set doc lockedness)
dup makedpkt
then then
nextchar
again drop
['] undoclock undop to ( set up the undo of this command )
startrange endrange killivls ( so the screen rewraps )
rewindow refresh resetcursor ( doesn't wrap, but show lock bars )
dirtytext? on ;
: DocLock ( -- )
local startrange local endrange local lockdoc?
local numdocs ( track of number of docs locking )
?kval curop to ( since a 'special' key, set curop )
clearundo
bos ( start finding the beginning of range )
?extended if nextchar then ( special case for extended )
prevdoc startrange to ( start of range to set )
eos prevchar prevchar nextdoc endrange to ( end of range to set )
widecursor? bos c@ ds = and ( a special case if wide on a ds )
if bos startrange to
eos prevchar nextdoc endrange to
then
startrange lockdoc? off ( assume we will be unlocking )
numdocs off ( assume we won't find any documents )
begin dup endrange < while ( while still in the range )
dup getdpkt #lock c@ lok <> ( is this document locked? )
if lockdoc? on then ( if not, then we will lock )
1 numdocs +to ( have found another document )
nextchar nextdoc
again drop ( clean up the stack )
numdocs needtext outofroom ( see if enough room for undo buffer )
curop lastop <> learnbuff and ( if first time while learning )
if lockdoc? on then ( then force locking the docs )
startrange
begin
endrange nextdsorcalc ( find next break or calc )
dup endrange < while ( see if still in range )
dup c@ fe and &calc = ( see if a calc token of either type )
if lockdoc? if &lockedcalc else &calc then ( set what we will do )
over c! ( and [un]lock the token )
else dup c@ ds = ( see if a document token )
if -1 bou +to ( increment pointer to save )
dup getdpkt #lock c@ bou c! ( save old state of document)
lockdoc? if lok else markbl then ( find what we will do to doc)
#lock c! ( and [un]lock the document )
dup makedpkt
then then
nextchar
again drop
['] undoclock undop to ( set up the undo of this command )
startrange endrange killivls ( so the screen rewraps )
rewindow refresh resetcursor ( doesn't wrap, but show lock bars )
dirtytext? on ;
code <insertcopy> ( from to lim -- from' to' )
sp )+ d2 move, ( d2: limit )
sp )+ a1 move, sp )+ a0 move, ( a1: destination, a0: source )
begin, a0 )+ d0 .b move, ( d0: byte, first test, then move )
ds #n d0 .b cmp, ne ( first test is for a document )
while,
d0 d1 move, fe #n d1 .b and, ( we can ignore the 1 bit )
&calc #n d1 .b cmp, ne ( assume lockedcalc is calc+1 )
while, a0 d2 cmp, ge ( not calc, are we still in range? )
while, d0 a1 )+ .b move, ( yes, store at destination)
again, 1 #n a0 subq, ( back of source addr to calc/lim-1 )
a0 sp -) move, a1 sp -) move, next;
: insertcopy ( addr destination len -- dest' )
local lim >r over r> + lim to ( hold limit of range )
begin lim <insertcopy> ( copy first part )
over lim < while ( finished? )
over c@ ds = ( if stopped on a document )
if over getdpkt markbl #lock c! dup makedpkt ( unlock document )
dpktsize + swap dpktsize + swap ( and bump lengths )
else copypocket then ( else stopped on a pocket )
again nip ; ( no, copy calculation )
: Copy ( -- ) ( tlh 6/23:1:03 )
local priorbos
gap prevchar inresult? beot inresult? and
if beot pastresult dup beot <>
if eos to movegap else drop ( so calculations will work )
then then
forceop on savepos extend ( make sure op will be set )
bos dup bor = if nextchar then ( find range of current selection )
eos dup eor = if prevchar then
< 0= ( if there is no text to legally copy )
if exit then
clearundo selected
bos bor = if bos nextchar bos to then ( don't copy initial doc )
eos eor = if eos prevchar eos to movegap then ( nor last doc )
selsize needtext outofroom ( see if have enough room to copy )
bos priorbos to ( autoextend this command )
gap prevchar lockedtext? ( does the sel end in locked text? )
if bos selsize ( remember selection )
beot prevchar ( look at last char of selection )
dup c@ ds <> ( see if it is a doc )
if nextdoc ( else nextchar) then ( if it isn't a doc, get next doc )
begin dup nextchar lockedtext? while ( see if next doc is also locked )
dup eor prevchar < while ( make sure still in the text )
nextdoc
again
dup eor prevchar < if nextchar then ( if not at end, put after ds )
dup eor prevchar = over lockedtext? and ( see if will still be locked )
if nocopy error drop 2drop exit then ( say so )
eos to movegap ( this is where the insertion goes )
beot eor prevchar = ( see if need an extra document )
beot lockedtext? and ( only if beot is really locked )
if nocopy error 2drop exit ( new test here )
gap prevchar beot killivls ( force rewrap around here )
op pop to gap op to ( so the ds is part of copied sel )
gap dpktsize gap +to ( allocate space for the packet )
markbl #lock c! ( make sure doc will not be locked )
makedpkt preset ( and make the packet there )
else op pop to gap op to ( set up the selection )
then
gap 5 + swap insertcopy ( duplicate the selection )
( gap 5 + swap over - gap swap ( set up the source, dest, len for move)
( dup gap +to move gap prevchar bos to ( insert the text )
op beot killivls forceop on ( make sure we will rewrap )
gap 5 + swap over - insertblock ( and insert the copy )
op findchar ( find state just before new sel )
op prevbrk dup brk+ swap fpkt? ( if no packet, make one )
if drop else pktsize makespace makepkt then
priorbos findchar
gap prevbrk dup brk+ swap fpkt? not ( also pkt on last brk in sel )
if pktsize makespace
then makepkt ( that is same as before original sel )
op prevbrk gap prevbrk <swappkt> ( and swap the two packets )
( ** undo of this should be Erase, then redo would re-insert buffer )
else bos gap 5 + selsize insertcopy ( make a copy of selection )
priorbos bos to
gap 5 + swap over - insertblock ( insert the copy )
priorbos findchar ( find the format at the start of sel )
op gap pktbytes ( pkts in sel, fix preceding region )
if op prevbrk dup brk+ swap fpkt? not if pktsize makespace then
makepkt ( fix beginning of new copy of selection )
then
then selected op bos to redisplay ( new copy is selected )
eos prevchar bos = ( select appropriate cursor )
if widecursor else extendedcursor then fixcursor ['] Uncopy undop to ;
: Uncopy ( -- ) ( tlh 2/27:16:31 )
pushpos bos <removeselection> drop gap to preset
dirtytext? on ['] Copy undop to rewindow swappos ;
( tlh 6/12:11:59 )
: Titles local line local xbos local xeos local topdoc local lastdoc
bot topdoc to eot prevchar prevdoc lastdoc to
bos xbos to eos xeos to bot bos to bot eos to cls
begin topdoc prevchar firstseen line to
begin
begin dup eot prevchar prevchar > if drop eot prevchar leave then
nextdoc dup getdpkt #ipage w@ dup 8000 > if ffff0000 or then 1 <
until dup findchar
begin line update! wrap 2 #iprint w! 0 #pgl ! 0 #ipage w!
line storeline 1 line +to
#wr @ c@ page? #spr c@ 0= and line lastseen > or
until
line lastseen >
until drop refresh
begin waitkey
?ctl not if xeos eos to xbos bos to
rewindow refresh resetcursor exit then
<key> upkey? not
if scancode dup 36 =
if drop topdoc bot > if topdoc prevdoc topdoc to then leave
else 3e =
if lastseen loadline #wr @ eot < topdoc lastdoc < and
if topdoc nextdoc topdoc to then leave
then
then
then
again
again ;
: DiskTitle ( -- )
local count 20 count to
?extended ( if selection is extended )
if <# ( get ready to convert sel )
0 selsize ( for the size of the selection)
do i bos + c@ ( get the last byte )
dup spc &lastacc inrange ( see if it is legal )
if hold -1 count +to ( if so, hold it and count down)
count 0= if leave then ( if we've run out, we're done )
else drop then ( else, clean up stack )
-1 +loop 0 #> ( and leave the string on stack)
?dup if screensave$ "to else drop then ( if any chars, change string )
collapse widecursor ( and collapse the selection )
else forceop on screensave$ insertblock ( if not extended, give back )
gap prevchar bos to redisplay widecursor ( string )
then undop off ; ( no undo for either )
code retp@
rp sp -) move, next;
code retp!
sp )+ rp move, next;
code stack!
sp )+ sp move, next;
: Ans ( ?? -- \ forth: -- str len )
Forth? wheel@ or 0= ( if neither flag is set )
if " Enable Forth Language" ( magic phrase )
dup selsize = rot rot bos swap same? and ( see if strings are the same )
if Forth? on " Forth Enabled" error ( if same, turn on and say so )
else noanswer error then exit ( if not phrase, error )
then
temp-rp 0= Forth? wheel@ or and ( if no query and Forth is on )
if clearundo forceop on extend ( forth interpretation )
indforth rule ( put up nice indicator )
selected beot partknown ( set up as for insertion )
bos beot killivls
bos gap over - interpret ( interpret whole selection )
?extended
if collapse ( if still extended, collapse )
else gap visible? ( use correct display word )
if redisplay else new-display then
then
forceop on widecursor ( and set up the cursor again )
" " 3 indicate exit
then
temp-rp 0= ( if no query in effect )
if ['] user vopen bos gap over - <find> ( only look in user )
if swap drop execute ( if we found it, execute word )
else drop notanswer error then ( else, give nice message )
else temp-rp retp! temp-sp stack! ( query from a program )
temp-rp off temp-sp off ( clear query )
extend bos gap over - ( return to query the selection)
then undop off ;
: Forth ( ?? -- \ forth: -- str len )
Forth? wheel@ or 0= if exit then ( if forth isn't on, do nothing)
clearundo forceop on extend ( forth interpretation )
indforth rule ( put up nice indicator )
selected beot partknown ( set up as for insertion )
bos beot killivls
bos gap over - interpret ( interpret whole selection )
?extended
if collapse ( if still extended, collapse )
else gap visible? ( use correct display word )
if redisplay else new-display then
then
forceop on widecursor ( and set up the cursor again )
" " 3 indicate ;
: Escape
Forth? wheel@ or if quit then ;
: Kb1/2 ( -- )
modifiers 1 and
if modifiers fffe and modifiers to
shiftstate fffe and shiftstate to
else 1 modifiers or modifiers to
1 shiftstate or shiftstate to
then ['] Kb1/2 undop to ;
: Undo ( -- | execute the token in undop if there is one )
%undo curop to
undop ?dup if execute then ;
( tlh 3/22:22:14 )
: adjustleaprange ( -- | sets the local leap range to prev&next docs )
bos bot >
if bos narrowcursor? not if nextchar then prevdoc bor to then
eos eot <
if eos narrowcursor? ?extended or if prevchar then ( check if on ds )
dup c@ ds <> if nextdoc then nextchar eor to then ;
: checklocallight ( -- )
bor bot = eor eot = and
if " " 2 indicate else indlocal then ;
: undolocal/global ( -- )
bor eor ( hold new values )
bou @ bor to bou 4 + @ eor to ( reset old values )
bou 4 + ! bou ! ( and prepare for redo )
op bor max eor prevchar min op to ( adjust op & pop )
pop bor max eor prevchar min pop to ( into area too )
checklocallight ( reset the local light )
resetcursor dirtytext? on ; ( reset the cursor again )
: local/global ( toggles state of local and global leaping )
clearundo ( set up to save range in undo buffer )
8 needtext outofroom ( see if there is enough room for undo buffer )
-8 bou +to
bor bou ! eor bou 4 + ! ( save away the range )
['] undolocal/global undop to
curop lastop <> learnbuff and ( if special learn case or )
bor bot = eor eot = and or ( if already at full range )
if adjustleaprange ( then adjust inward )
else bot bor to eot eor to ( else set to whole universe )
then
op bor max eor prevchar min op to ( adjust op & pop )
pop bor max eor prevchar min pop to ( into area too )
checklocallight
dirtytext? on ;
( 4/30/87 Code for Receive )
: receivable? ( char -- flag, true if okay to receive this char )
dup 20 7f inrange
over tb = or
over pb = or
swap rtn = or ;
: noreceiving? ( -- flag, true if no changes in the receive buffer)
oldrxptrs rxpointers = ;
: unreceive ; ( -- , a dummy undo that is used as a flag in undop )
: verifyfmtpkt ( addr-of-pkt endaddr -- addr' endaddr' )
local end end to
local addr addr to
local err err off
addr c@ &fmt = ( if have a format packet )
if pktsize 1 ( verify packet is full size )
do i addr + c@ &firsthid and &firsthid <> ( bytes must be hidden )
i addr + end > or ( must still be in selection)
if err on leave then ( if a problem, turn on errflag)
loop
err not ( if still okay )
if addr getpkt ( pick up the packet )
#lsp c@ 1 3 inrange not if err on then ( and verify each field)
#left c@ 0 a0 inrange not if err on then
#indent c@ 0 a0 inrange not if err on then
#wide c@ 2 a0 inrange not if err on then
#iwide c@ 2 a0 inrange not if err on then
#just c@ 0 3 inrange not if err on then
( tabs are always okay )
#left c@ #wide c@ + 2 a0 inrange not if err on then
#indent c@ #iwide c@ + 2 a0 inrange not if err on then
#left c@ #wide c@ + #indent c@ #iwide c@ + <>
if err on then ( verify right margin is consistent )
then
err ( if an error anywhere )
if addr 1+ ( start at next byte )
begin dup end < while ( while still in range )
dup c@ &firsthid and &firsthid = while
1+ ( move onto next byte )
again
dup addr - swap ( calc length of part removed )
addr over end swap - move ( end-of-pkt addr len )
negate end +to ( and remove from end )
badtransmit error
else pktsize addr +to ( was okay packet )
then
then
addr end ;
code unhidebyte ( encodedbyte -- byte )
sp ) d0 move, ( get copy of byte )
000f #n sp ) and, ( remember low nybble here )
0f00 #n d0 and, ( get second nybble in register )
4 #n d0 lsr, ( shift down into place )
d0 sp 3 )d .b or, ( and place into stack )
next;
: verifycalc ( addr-of-calc endaddr -- addr' endaddr' )
local end end to
local addr addr to
local err err off
addr c@ &calc =
if 5 1
do i addr + c@ &firsthid and &firsthid <>
i addr + end > or
if err on leave then
loop
err not
if 1 addr +to ( then valid calc thingy )
['] redefinerror aencode addr ! ( change token to redefine )
4 addr +to ( and accept that too )
begin
addr end < while ( while more chars )
addr c@ &firsthid and &firsthid = while ( if done, just exit )
addr 1+ c@ &firsthid and &firsthid <> ( if not even number )
addr 1+ end < not or ( or not enough chars )
if err on leave then ( then have error, done)
addr w@ unhidebyte ( get the character )
spc &lastasc inrange not ( only legal chars in pockets )
if ascii ? hidebyte addr w! then ( if not, make a default char )
2 addr +to
again
then
err
if addr ( start at next byte )
begin dup end < while ( while still in range )
dup c@ &firsthid and &firsthid = while
1+ ( move onto next byte )
again
dup addr - swap ( calc length of part removed )
addr over end swap - move ( end-of-pkt addr len )
negate end +to ( and remove from end )
badtransmit error
then
then
addr end ;
: verifybreak ( addr-of-break endaddr -- addr' endaddr' )
local end end to
local addr addr to
addr c@ rtn = addr c@ pb = or
if 1 addr +to ( this char is now okay )
addr end verifyfmtpkt ( and see if a format packet )
else addr end then ; ( else, do nothing )
: verifydoc ( addr-of-doc endaddr -- addr' endaddr' )
local end end to
local addr addr to
local err err off
addr c@ ds = addr end < and
if dpktsize 1 ( verify packet is full size )
do i addr + c@ &firsthid and &firsthid <> ( bytes must be hidden )
i addr + end > or ( must still be in selection)
if err on leave then ( if a problem, turn on errflag)
loop
err not ( if still okay )
if addr getdpkt ( pick up the packet )
#long w@ 3 < if err on then ( and verify each field)
( #above is always okay )
( #below is always okay )
#lock c@ dup lok <> swap markbl <> and
if err on ( if not okay, then error )
else markbl f0 or %lock %long - 2* 1- addr + c! then ( unlock it)
( #ipage is always okay )
( #iprint is always okay )
then
err ( if an error anywhere )
if pb addr c! ( make ds into a page break )
1 addr +to ( and it is okay now )
addr ( start at next byte )
begin dup end < while ( while still in range )
dup c@ &firsthid and &firsthid = while
1+ ( move onto next byte )
again
dup addr - swap ( calc length of part removed )
addr over end swap - move ( end-of-pkt addr len )
negate end +to ( and remove from end )
badtransmit error
else dpktsize addr +to ( was okay packet )
then
addr end verifyfmtpkt ( leaves addr and end on stack )
else addr end ( do nothing with it? ) then ;
: verifynonaccentable ( addr end -- addr' end' )
local end end to
local addr addr to
addr c@ &lastasc 1+ &lastchr inrange ( only bare accents )
addr c@ tb = or ( or tab char, are non-accentable )
if 1 addr +to ( this char passes )
addr c@ &attr $bold 1 shr or dup $uln $dln or 1 shr or inrange
if 1 addr +to then
then addr end ;
: verifyaccentable ( addr end -- addr' end' )
local end end to
local addr addr to
addr c@ spc &lastacc inrange ( only normal characters )
if 1 addr +to ( this char passes )
addr c@ &attr $bold 1 shr or dup $uln $dln or 1 shr or inrange
if 1 addr +to then
addr c@ &firstacc &lastacc inrange
if 1 addr +to then
then addr end ;
: verifychar ( addr end -- addr' end' )
over c@
dup spc &lastasc inrange
if drop verifyaccentable
else dup &lastasc 1+ &lastchr inrange ( &lastacc -> &lastasc )
if drop verifynonaccentable
else dup tb =
if drop verifynonaccentable
else dup rtn = over pb = or
if drop verifybreak
else dup ds =
if drop verifydoc
else drop swap ascii ? over c! 1+ swap ( not a valid char)
badtransmit error ( and give message )
then then then then then
over c@ &calc =
if verifycalc then ;
: ctocreceive ( -- , handles cat to cat receiving )
local pos local len
local oldundop
pos off
gap 5 + 2legalc? + bou < not recch? and ( if we are out of room! )
if noroom error
auto-answer? ( if we auto-answered also, hang up )
if xon.reset ( make sure we can transmit )
6 0 do 3 sendchar loop 200 ms ( indicate we are hanging up )
reset.modem 100 ms
begin recch? while recget drop again ( flush receive buffer )
[ ticks/min 3c / ] literal 4 * mticks!
indphone rule
then
then
2legalc? ( do we have two legal chars in buffer?)
mticks@ 0= noreceiving? and recch? and or ( or have we timed out?)
rcfull? or
if gap prevchar dup c@ ds = ( if char is a doc )
if narrowcursor? not ( if a wide or extended cursor )
beot eor <> and ( and not at end of text )
if nextchar then then ( then advance to check beot )
findchar #lock c@ lok = ( save state of lockedness )
if lockedtext error cursoron exit then ( give error message )
then
rcfull? 2legalc? 0= and ( if buffer is full & not 2 chars )
if undop oldundop to clearundo ( get space now )
gap 5 + pos to ( set up insertion point )
pos bou < ( if we have enough room )
if recget ( start with the first char in buffer )
pos c! 1 pos +to then ( and store it away )
begin begin recch? until ( wait for next char )
rcpeek ( see if we've gone far enough )
0 &lastasc inrange not while ( done if it is a legal start of char )
recget ( otherwise, get the character )
pos bou < ( and see if we have enough room for it)
if pos c! 1 pos +to ( if so, get the char and store it )
else drop then ( else drop it on the floor )
again
pos bou < not ( if we didn't have enough room )
if gap 7 + pos to then ( then keep char and possible attrib )
then
2legalc? ( do we have two legal chars in buffer?)
mticks@ 0= noreceiving? and recch? and or ( or have we timed out?)
if pos 0= ( if we haven't initialized pos )
if undop oldundop to clearundo ( get as much space as possible )
gap 5 + pos to ( and set pos )
then
begin
pos 2legalc? + bou < while ( if we are out of space, we are done)
recget ( get the received character )
dup 7 = ( if it is a bell )
if drop boop ( then just sound the bell )
else dup 5 =
if drop answerback? if answerback sendstring then
else dup 3 = modemconnect? and ( ETX=hang up? )
if drop ( clean up the ETX )
[ ticks/min 3c / ] literal mticks! ( wait for 1 second)
begin recch? <?k> or ( wait for char or key )
mticks@ 0= or ( or timed out )
carrier? 0= or ( or loss of carrier )
until
recch? if rcpeek 3 = ( if char and its ETX )
if ( mnp? if indicate hangup)
reset.modem 100 ms ( then hangup )
begin recch? while recget drop again
4 [ ticks/min 3c / ] literal * mticks!
carrierlost error
indphone rule
then then
else pos c! 1 pos +to then ( else prime receive )
then
then
begin
recch? while ( we better still have chars in buffer )
rcpeek ( peek ahead at next character )
0 &lastasc inrange not while ( done when it is a legal char )
recget pos c! 1 pos +to ( otherwise store the char away )
pos bou < while ( same in here, will exit on above vers)
again
2legalc? 0= ( keep going until not two legal chars )
sendport? sprt = ( unless connected to a modem )
trained? or and ( and phone was hung up on last char )
recch? not or ( or no more characters at all )
until
then
pos gap 5 + - len to ( find the length of stuff received )
gap 5 + pos to ( and reset start of buffer )
len 0 > ( if there is anything to insert )
if cursoroff ( turn off the cursor first )
pos c@ 01 = 1 len < and ( if first char in buffer is pkt marker)
if pos 1+ pos len + 1- ( range to check format packet on )
verifyfmtpkt ( see if okay format packet )
over pos 1+ pktsize + = ( if start is a full packet away )
over pos len + 1- = and ( and if lengths are still same, okay )
if 2drop ( clean up stack )
pos workpkt pktsize 1+ move ( get the packet into workpkt )
forceop gap op < or op bor = or ( if going to insert at gap )
if gap narrowcursor? eos eor = or
if prevchar then ( see if we are narrow )
prevbrk fpkt? not ( if no packet on previous break )
if pos pos pktsize + len move pktsize pos +to ( make space )
gap narrowcursor? eos eor = or
if prevchar then
prevbrk dup findchar ( find format there )
brk+ pktsize makespace ( and make a packet )
makepkt
then
gap narrowcursor? eos eor = or ( check if narrow )
if prevchar then prevbrk ( now there is a packet )
workpkt <swappkt> ( swap in the work packet )
narrowcursor? eos eor = or
gap prevchar c@ break? and ( special case )
if gap prevchar ( if so, use break before gap )
else beot endtext firstbreak then ( use place after beot )
fpkt? not ( pkt after beot?)
if narrowcursor? eos eor = or
gap prevchar c@ break? and ( special case )
if gap prevchar ( use break before gap )
else beot endtext firstbreak then ( after beot)
brk+ pktsize makespace ( and make one there )
workpkt 1+ swap pktsize move ( but put in work pkt )
then
else op prevbrk fpkt? not ( if no packet on prev break )
if pos pos pktsize + len move pktsize pos +to ( make space )
op prevbrk dup findchar ( find format there )
brk+ pktsize makespace ( and make a packet )
makepkt
then
op prevbrk ( now there is a packet )
workpkt <swappkt> ( swap in the work packet )
op nextbrk fpkt? not ( if no packet after op )
if op nextbrk brk+ pktsize makespace ( then make one)
workpkt 1+ swap pktsize move ( but put in work pkt )
then
then
1 pktsize + dup pos +to ( advance pos past packet )
negate len +to ( and adjust length, too )
else swap dup pos to - len to ( reset pos and len )
then
then
pos pos len + ( the range to verify over )
begin 2dup < while
over c@ 0= ( see if it is a zero, which is okay )
if 2dup over - over 1+ swap move ( remove the zero )
1- ( and the end is one byte in now )
else verifychar then ( verify every other char received )
again
pos - len to drop ( reset length )
len 0 > not ( if we didn't have any verified chars )
if cursoron exit then ( out of here anyways )
pos 2legalc? + bou < not recch? and ( see if ran out of room )
if noroom error then
forceop gap op < or op bor = or ( see which insertion point to use )
if oldundop ['] unreceive = ( see if last op was receive )
if forceop off then ( if so, don't reset op )
pos len insertblock ( insert the text at the gap )
gap prevchar bos to ( reset our selection )
redisplay widecursor forceop on ( leave forceop on when done )
['] unreceive undop to ( and set our undo )
else bou gap - len 2* < ( need twice the size of new insertion )
if pos gap len move ( if not enough, prepare for reverso )
op gap over - reverse ( reverse parts )
gap len reverse
op gap len + over - reverse
op gap len realign ( and adjust pointers )
len gap +to ( set the gap correctly )
else pos len ( addr and len of insertion )
eou over - dup bou to swap move ( move into undo buffer)
op len makespace ( make a hole for stuff)
bou swap len move ( and move stuff in )
clearundo ( toss stuff in buffer )
then
undop off
op beot killivls
beot partknown
gapline firstseen - op gap fit-display
resetcursor
then
cursoron von ( make sure display stays on )
trained? ( if we are still trained )
if [ ticks/min 3c / ] literal mticks! then ( reset timer to 1 sec )
then
noreceiving? not ( if pointers have changed )
if rxpointers oldrxptrs to ( save new pointers )
[ ticks/min 3c / ] literal mticks! ( reset timer to 1 second )
then ;
: <receive> ( -- | called everytime through the main equit loop )
local pos local len ( last received char and length received )
local oldundop ( what the undop was before receive )
recch? ( see if anything received )
if ?lex ?rex or ?ctl or lexxing or not ( make sure not doing something)
if cursoroff
gap prevchar dup c@ ds = ( if char is a doc )
if narrowcursor? not ( if a wide or extended cursor )
beot eor <> and ( and not at end of text )
if nextchar then then ( then advance to check beot )
findchar #lock c@ lok = ( save state of lockedness )
if lockedtext error cursoron exit then ( give error message )
undop oldundop to ( save what was in the undop before clearing it)
clearundo ( make as much space as possible )
gap 5 + pos to ( where to start saving the characters )
begin recch? while ( while more characters )
pos bou < while ( and while more space )
ibmsend?
if recget 2* receivetable + w@ ?dup ( +++ )
if dup 100 <
if pos c! 1 pos +to
else pos w! 2 pos +to then
then
else recget 7f and dup receivable? ( see if okay to insert char)
if pos c! 1 pos +to ( if so, store it away )
else dup 5 =
if drop answerback? if answerback sendstring then
else 7 = if boop then ( otherwise, see if a beep )
then
then
then
again
pos bou < not recch? and ( see if ran out of room )
if noroom error
auto-answer? ( if we auto-answered also, hang up )
if reset.modem 100 ms ( turn off modem )
begin recch? while recget drop again ( flush receive buffer )
[ ticks/min 3c / ] literal 4 * mticks! ( set timer to hangup)
indphone rule
then
then
pos gap 5 + - len to ( size of text to insert )
gap 5 + pos to ( and pos will be start of buffer )
len 0= if cursoron exit then ( if nothing to insert, we are done )
forceop gap op < or op bor = or ( see which insert point to use)
if oldundop ['] unreceive = ( see if last op was receive )
if forceop off then ( if so, don't reset op )
pos len insertblock ( insert the text at the gap )
gap prevchar bos to ( reset our selection )
redisplay widecursor forceop on ( leave forceop on when done )
['] unreceive undop to ( and set our undo )
else bou gap - len 2* < ( need twice the size of new insertion )
if pos gap len move ( if not enough, prepare for reverso )
op gap over - reverse ( reverse parts )
gap len reverse
op gap len + over - reverse
op gap len realign ( and adjust pointers )
len gap +to ( set the gap correctly )
else pos len ( addr and len of insertion )
eou over - dup bou to swap move ( move into undo buffer)
op len makespace ( make a hole for stuff)
bou swap len move ( and move stuff in )
clearundo ( toss stuff in buffer )
then
undop off
op beot killivls
beot partknown
gapline firstseen - op gap fit-display
resetcursor
then
cursoron von ( make sure display stays on )
then
then ;
: receive ( -- )
?lex ?rex or ?ctl or lexxing or not ( if not cmd or lexxing, then okay )
if sendport? none <> ( if we can receive from anywhere )
[ ph.rxbuf.len ] literal needtext 0= ( try to get some space )
if drop then ( if available )
if cattocat? ( which to do? )
if ctocreceive else <receive> then checkgauge
cursorstate rxch? 0= and ( bug 537 )
if cursoroff rule cursoron else rule then ( )
then then ;
( 29Apr87 Code for Send )
code sendtable nx ) jsr, ;c ( a ROM array for translating sent chars )
00000000 , 00000000 , 20202000 , 00000000 , ( 00-0f )
00000000 , 00000000 , 00000000 , 00200000 , ( 10-1f was 200.. )
20212223 , 24252627 , 28292a2b , 2c2d2e2f , ( 20-2f )
30313233 , 34353637 , 38393a3b , 3c3d3e3f , ( 30-3f )
40414243 , 44454647 , 48494a4b , 4c4d4e4f , ( 40-4f )
50515253 , 54555657 , 58595a5b , 5c5d5e5f , ( 50-5f )
60616263 , 64656667 , 68696a6b , 6c6d6e6f , ( 60-6f )
70717273 , 74757677 , 78797a7b , 7c7d7e20 , ( 70-7f )
80f1ba4f , 6fe18687 , 4c6c2020 , 6e4e208f , ( 80-8f )
90f89192 , 20202020 , 2020209b , 9c9d9e9f , ( 90-9f )
20202020 , fd33a6a7 , a8f620ab , acadaeaf , ( a0-af )
00000000 , 00000000 , 00000000 , 00000000 , ( b0-bf )
00000000 , 00000000 , 00000000 , 00000000 , ( c0-cf )
00000000 , 00000000 , 00000000 , 00000000 , ( d0-df )
00000000 , 00000000 , 00000000 , 00000000 , ( e0-ef )
00000000 , 00000000 , 00000000 , 00000000 , ( f0-ff )
code 2sendtable nx ) jsr, ;c ( +++ )
75c30081 , 65c00082 , 61c20083 , 61c30084 ,
61c10085 , 65c20088 , 65c30089 , 65c1008a ,
69c3008b , 69c2008c , 69c1008d , 41c3008e ,
45c00090 , 6fc20093 , 6fc30094 , 6fc10095 ,
75c20096 , 75c10097 , 79c30098 , 4fc30099 ,
59c3009a , 61c000a0 , 69c000a1 , 6fc000a2 ,
75c000a3 , 6ec600a4 , 4ec600a5 , 00000000 , ( 0000 indicates end )
: transend ( addr -- +++)
ibmsend? not
if c@ sendtable + c@ ?dup if sendchar then exit then
dup c@ swap
dup text endtext inrange ( see if looking in text )
if accent ( if so, use accent function )
else 3 + c@ ( assume in lbuff, must be accent or zero )
then ?dup ( see if char has an accent )
if c@ swap 8 shl or ( if so, get accentted character )
2sendtable ( look up table )
begin dup w@ while ( until we hit the end )
over over w@ = ( see if we found it )
if dup 2+ w@ sendchr exit then ( if so, get translation and send it)
4 + ( on to next entry )
again 8 shr sendtable + c@ ?dup
if sendchr then
else sendtable + c@ ?dup
if sendchr then
then ;
: selected? ( addr-in-lbuff -- flag, true if character is selected )
1+ c@ $inv and ; ( check the inverse bit of the attribute byte )
: displaybos ( bos -- )
bos inwindow ( find old bos in window )
if dup update! ( and mark it for update, if there )
else 0 then ( left with a window line on stack )
swap bos to ( set new bos )
bos inwindow ( see if still in window )
if over ( if both in window )
if swap over 2dup < ( if not the same line )
if swap do i update! loop ( mark all in range for update )
else 2drop then ( clean up the stack )
else swap drop then
dup firstseen lastseen inrange ( and still visible )
if update! refresh exit then ( if so, update also and display )
then ( if not still visible )
drop ( and drop previous screenline)
middle bos bos nextchar fit-display ; ( recenter display on bos )
: halfwide? ( addr-in-lbuff -- flag )
1+ c@ $half and ;
: sendline ( first-selected-in-lbuff -- )
local evenhalf? evenhalf? off ( if true, send next half space )
pagebreak? ( if line is a pagebreak )
if drop pb sendchar ( then print a pagebreak )
else begin dup selected? carrier? and while ( while still in selected part )
dup halfwide? ( if on a halfwide character )
if evenhalf? ( see if we should send this one )
if spc sendchar evenhalf? off ( if so, send a space )
else evenhalf? on then ( else set to send next half wide )
else dup transend ( send translate character )
then
lbufwide + ( onto the next char in lbuff )
again drop ( clean up address off of stack )
sendend$ ?dup ( send the end of line sequence )
if 0 do i over + c@ sendchar loop then drop
then #nextwr @ gap prevchar min ( bos for next line to send )
displaybos ; ( set bos and update display )
: formattedsend ( -- )
local curpos
gap 5 + curpos to ( this is place to put received stuff )
bos findchar wrap #wr @ prevwrap #nextwr ! build ( build up first line )
lbuff lbufwide 2* + ( start at the left edge of the line )
begin dup selected? 0= while ( find the first selected char )
4 +
again
dup 4 - c@ markbl = ( if last unselected is a markbl )
#nextwr @ gap < and ( and selection is more than a line )
if drop ( then send starts at left, enter loop )
else sendline then ( else don't send leading spaces )
begin ( main Send loop )
bos gap prevchar < ( while there is something to send )
?panic not and carrier? and while ( and it is still okay to send )
bos findchar ( find the bos again )
wrap #wr @ prevwrap #nextwr ! build ( build the next line )
lbuff lbufwide 2* + ( start at the start )
begin dup selected? 0= while ( until we hit the selected text )
spc sendchar 4 + ( emit spaces )
again
sendline ( then send the line )
recch? ( if a char received - assume buffer holds a lines worth )
if halfduplex?
if begin recch? while ( while more characters )
curpos bou < while ( and while enough room )
ibmsend?
if recget 2* receivetable + w@ ?dup ( +++ )
if dup 100 <
if curpos c! 1 curpos +to
else curpos w! 2 curpos +to then
then
else recget 7f and dup receivable? ( verify char is legal )
if curpos c! 1 curpos +to ( if so, store in gap )
else drop then ( else discard character )
then
again
else begin recch? while
recget drop again ( discard chars )
then
then
again
halfduplex? not ( if we are tossing characters )
if senddelay ms ( delay a bit for straggler chars )
begin recch? while ( see if any more chars in buffer )
recget 7f and break? not while ( if so, continue until a break)
again
then forceop on
gap 5 + curpos <
if forceop on ( newly received text can be selected )
gap 5 + curpos over - insertblock
forceop on ( so receive knows to put in at gap )
['] unreceive undop to ( flag to receive so it doesn't forceop)
rxpointers oldrxptrs to ( this is the current state of buffer )
[ ticks/min 3c / ] literal mticks! ( and last time stuff received )
then selected gap prevchar bos to redisplay widecursor ;
: unformattedsend ( -- )
local curpos
gap 5 + curpos to ( a place to put received stuff )
begin
bos findchar wrap ( leaves #wr pointing to start of next line )
#wr @ gap min bos ( get range of characters to send )
do i c@ ( get the next byte )
dup ds = if drop pb then ( turn documents to pages )
dup [ permspc ] literal = if drop spc then ( perm spc -> reg spc )
dup tb = over rtn = or over pb = or ( pass these controls through )
if sendchar ( if one of them, send it )
else drop i transend ( else, send translated char )
then
loop
#wr @ gap < ( see if we sent the whole selection )
?panic not and carrier? and while ( and if it is still okay to send )
recch? ( if a char received - assume buffer holds a lines worth )
if halfduplex?
if begin recch? while ( while more characters )
curpos bou < while ( and while enough room )
ibmsend?
if recget 2* receivetable + w@ ?dup ( +++ )
if dup 100 <
if curpos c! 1 curpos +to
else curpos w! 1 curpos +to then
then
else recget 7f and dup receivable? ( verify char is legal )
if curpos c! 1 curpos +to ( if so, store in gap )
else drop then ( else discard character )
then
again
else begin recch? while
recget drop again ( discard chars )
then
then
#wr @ displaybos ( if not, advance the display and the bos )
again
halfduplex? not ( if we are tossing characters )
if senddelay ms ( delay a bit for straggler chars )
begin recch? while ( see if any more chars in buffer )
recget 7f and break? not while ( if so, continue until a break)
again
then forceop on
gap 5 + curpos <
if forceop on ( newly received text can be selected )
gap 5 + curpos over - insertblock
forceop on ( so receive knows to put in at gap )
['] unreceive undop to ( flag to receive so it doesn't forceop)
rxpointers oldrxptrs to ( this is the current state of buffer )
[ ticks/min 3c / ] literal mticks! ( and last time stuff received )
then selected gap prevchar bos to redisplay widecursor ;
: deepsend ( -- )
local curpos
local len
gap 5 + curpos to ( a place to put received stuff )
bos gap firstbreak ( see if a break in the selection being sent )
if bos findchar workpkt makepkt ( find the format at the bos )
01 sendchar ( send indicator for initial packet )
pktsize 0 ( for the size of the packet )
do i workpkt + c@ sendchar loop ( send the body of the packet )
then
begin
bos findchar wrap ( leaves #wr pointing to start of next line )
#wr @ gap min bos ( get range of characters to send )
do i c@ sendchar ( get the next byte and send it )
loop
#wr @ gap < ( see if we sent whole selection yet )
?panic not and carrier? and while ( and if it is okay to still send )
2legalc? ( if something received )
if begin
curpos 2legalc? + bou < while ( if no space, we are done )
recget curpos c! 1 curpos +to ( if so, prime receive )
begin
recch? while ( we better still have chars in buffer )
rcpeek ( peek ahead at next character )
0 &lastasc inrange not while ( done when it is a legal char )
recget curpos c! 1 curpos +to ( otherwise store the char away)
curpos bou < while ( same in here, will exit on above vers)
again
2legalc? 0= ( keep doing this until on last char )
until
then
#wr @ displaybos ( if not, advance the display and the bos )
again
forceop on
gap 5 + curpos <
if curpos gap 5 + - len to ( the length of the received text )
gap 5 + curpos to ( and this is start of received text )
curpos c@ 01 = ( if first char in buffer is pkt marker)
if curpos 1+ curpos len + 1- ( range to check format packet on )
verifyfmtpkt ( see if okay format packet )
dup curpos len + 1- = ( if still ends at same place, was okay)
if 2drop ( clean up stack )
curpos workpkt pktsize 1+ move ( get the packet into workpkt )
gap prevbrk fpkt? not ( if no packet on prev break )
if curpos dup pktsize + len move pktsize curpos +to
gap prevbrk dup findchar ( find format there )
brk+ pktsize makespace ( and make a packet )
makepkt
then
gap prevbrk ( now there is a packet )
workpkt <swappkt> ( swap in the work packet )
beot endtext firstbreak fpkt? not ( if no pkt after beot )
if beot endtext firstbreak brk+ pktsize makespace ( make one)
workpkt 1+ swap pktsize move ( but put in work pkt )
then
1 pktsize + dup curpos +to ( advance curpos past packet )
negate len +to ( and adjust length, too )
else swap dup curpos to - len to ( reset curpos and len )
then
then
curpos dup len + ( range of new text )
begin 2dup < while
over c@ 0= ( see if it is a zero, which is okay )
if 2dup over - over 1+ swap move ( remove the zero )
1- ( and the end is one byte in now )
else verifychar then ( verify every other char received )
again
curpos - len to drop ( set new end of stuff )
forceop on ( newly received text can be selected )
curpos len insertblock
forceop on ( so receive knows to put in at gap )
['] unreceive undop to ( flag to receive so it doesn't forceop)
rxpointers oldrxptrs to ( this is the current state of buffer )
[ ticks/min 3c / ] literal mticks! ( and last time stuff received )
then selected gap prevchar bos to redisplay widecursor ;
: Send ( -- )
sendport? none = ( if not connected to anything )
if nomodem error exit then ( then say so, and we're done )
trained? not ( if we're not trained )
modemconnect? and ( and not serial or external )
if begin ringstate until ( wait for phone to stop ringing )
offhook ( else pick up the phone )
phwait rule ( turn on phone indicator )
7d0 ms ( wait 2 seconds )
sendport? xmdm = ( if we are connected to external modem)
if xon.reset ( make sure we can transmit )
" AT" sendstring 0d sendchar ( initialize modem first )
modemdefault$ sendstring 0d sendchar
modeminit$ sendstring 0d sendchar
" ATD" sendstring 0d sendchar ( force modem to originate mode)
carriertimeout [ ticks/min 3c / ] literal * trainexternal
else carriertimeout ( and try to get a connection )
[ ticks/min 3c / ] literal * trainanswer
then
setmodem ( set indicators as needed )
trained? not ( if still not trained )
if noconnect error collapse widecursor exit then ( then can't send )
then
cattocat? ( if we are sending cattocat )
if extend deepsend ( send EVERYTHING! )
else sendend$ swap drop ( see if line end contains something )
if undop ['] receive = curop lastop = or ( if last was send or receive )
if sendend$ 0 do i over + c@ sendchar loop drop ( send a line end )
else extend formattedsend ( else send with space formatting )
then
else extend unformattedsend then ( otherwise just send surface text )
then ?panic if xon.reset then ;
( an array of scancodes and translated values for non-alphabetic control chars )
code specialctrl nx ) jsr, ;c
2000 w, 101c w, 081d w, 001e w, 011f w, 321b w, 3b7f w, 2d0d w, ffff w,
( 2-nul 3-fs 4-gs 5-rs 6-us tab-esc erase-del rtn-rtn endmarker )
: SendCtrl ( -- )
xon.reset ( make sure we can transmit )
begin
waitkey ( wait for a key event )
panicked off ( make sure they aren't panicked out )
?ctl while ( quit if the use-front key isn't down )
<key> stripshifts ( if still down, get the key )
dup ascii a ascii z inrange ( if key is a letter key )
if ascii a - 1+ sendchar ( translate to control code )
else spc = ( see if the space bar )
if txbreak ( if so, send a break signal )
else specialctrl ( else, see if a special key )
begin
dup w@ ffff <> while ( until we hit end of list marker )
dup c@ scancode = ( if the scancode matches )
if dup 1+ c@ sendchar leave then ( send the next byte )
2+ ( on to next scancode )
again drop ( remove address of list )
then
then
again ; ( check next key )
: SendPswrd
xon.reset ( make sure we can transmit )
begin
waitkey ( wait for a key )
panicked off ( make sure they aren't panicked out )
?ctl while ( while the use-front key is down )
<key> stripshifts ( get the character )
dup shiftkey? ( if it is a shift key )
if drop ( then do nothing with it )
else dup erase = ( special translation for erase )
if drop 7f sendchar ( turn it into a DEL )
else dup ds = if drop pb then ( turn documents to pages)
dup tb = over rtn = or over pb = or ( pass these ctrls thru)
if sendchar ( if one of them, send it )
else dup 0ff > ( if char is accented )
if 8 shr then ( then only use base part of char )
sendtable + c@ ?dup ( else do our translation )
if sendchar then ( and send if needed )
then
then
then
again ;
( each lower level of handler sets curop as desired. <equit> will correctly
advance curop to lastop. )
: <equit> ( -- )
( local oldsp ( holder for stack verification )
eot markpoint to ( force fixivl to one at a time )
btable 100 -1 fill btable 20 + a0 0 fill 0 btable 0d + c! -1 btable 93 + c!
edde on crt off
norefresh off
preset rewindow
firstseen gapline to
redisplay resetcursor
checkline# checkgauge checkbattery 0 0 3 indicate
resetphonelight checklocallight rule
panicked off ( reset the panicked state )
typermode off ( make sure typermode isn't on )
cursoron
begin ( sp@ oldsp to) <?k> ( save current stack level )
if <key> cursoroff ( start by turning off the cursor )
cursor? if cy firstseen + loadline then ( reset ruler before commands )
curop lastop to ( and set lastop to the last event )
?lex ?rex or lexxing or
if do-lex ( if a leaping event )
else ?ctl
if do-cmd ( if a command )
else dup stripshifts erase =
if drop Erase
else dup stripshifts undo =
if drop Undo
else Insert
then
then
then
then
panicked off von ( no need to panic beyond here)
cursor? ( if the cursor is visible )
if checkline# checkgauge checkbattery
rule cursoron then ( make sure cursor is on )
learnerror if nolearnroom error learnerror off then
else fixivl then ( if no key, then fix interval )
recch? if receive then ( see if should receive )
periodicevents ( and handle periodic events )
( sp@ oldsp <> if " There is a problem on the stack!" error then ( give msg )
again ;
: diskaddr ( addr -> o t | From addr get trk# & offset, b=-1 if not saved)
ramend over u< over ramstart u< or ( not saved?)
if drop 0 -1
else ramstart - 1400 /mod diskoffset + then ; ( compute b# & offset )
: disk>mem ( offset track# addr len -- error-flag )
local length local address local track# local offset local error
length to address to track# to offset to error off
begin trkbuf track# rtrk dup -1 = if ?diskerror then
error or error to ( remember error flags )
trkbuf offset + address 1400 offset - length min
dup negate length +to dup address +to move
1 track# +to 0 offset to length 0 > not until error ;
: getforward ( -- )
local err local addr
emptytext? not abort" Text must be empty for disk transfer to work"
initedde idblock ?diskerror ( get an id block if possible)
[ .s/r 66 + ] literal w@ 3325 = ( so will work with old )
if 1 diskoffset to ( and new disks )
else [ .s/r 66 + ] literal w@ 3326 =
if 3 diskoffset to
else romcopyup error abort
then
then
8c @ptr ( packedendtext) f0 @ptr ( packedtext) - ( size of text on disk )
184 @ptr 18c @ptr + 194 @ptr + 19c @ptr + ( find the size of all )
1a4 @ptr + 1ac @ptr + 1b4 @ptr + 1bc @ptr + ( the learn strings )
1c4 @ptr + 1cc @ptr + + ( and total it all )
needforth ( see if have room )
if 184 @ptr if 180 @ptr diskaddr 0 184 @ptr learn0 "to learn0 disk>mem
if " " learn0 "to then then
18c @ptr if 188 @ptr diskaddr 0 18c @ptr learn1 "to learn1 disk>mem
if " " learn1 "to then then
194 @ptr if 190 @ptr diskaddr 0 194 @ptr learn2 "to learn2 disk>mem
if " " learn2 "to then then
19c @ptr if 198 @ptr diskaddr 0 19c @ptr learn3 "to learn3 disk>mem
if " " learn3 "to then then
1a4 @ptr if 1a0 @ptr diskaddr 0 1a4 @ptr learn4 "to learn4 disk>mem
if " " learn4 "to then then
1ac @ptr if 1a8 @ptr diskaddr 0 1ac @ptr learn5 "to learn5 disk>mem
if " " learn5 "to then then
1b4 @ptr if 1b0 @ptr diskaddr 0 1b4 @ptr learn6 "to learn6 disk>mem
if " " learn6 "to then then
1bc @ptr if 1b8 @ptr diskaddr 0 1bc @ptr learn7 "to learn7 disk>mem
if " " learn7 "to then then
1c4 @ptr if 1c0 @ptr diskaddr 0 1c4 @ptr learn8 "to learn8 disk>mem
if " " learn8 "to then then
1cc @ptr if 1c8 @ptr diskaddr 0 1cc @ptr learn9 "to learn9 disk>mem
if " " learn9 "to then then
else drop then ( if not enough room, clean up )
8c @ptr ( packedendtext) f0 @ptr ( packedtext) - ( get size of text )
needtext outofroom ( make sure allocated )
gap beot over - ascii ? fill preset ( fill with questions )
f0 @ptr ( disktext ) diskaddr text ( get text into mem )
8c @ptr ( top of mem ) f0 @ptr ( disktext ) - disk>mem err to
e4 @ptr ( diskbou ) f0 @ptr ( disktext ) - text + ( start of 2nd part )
8c @ptr ( top of mem ) e4 @ptr ( diskbou ) - ( size of second part)
dup endtext swap - dup bou to swap move ( slide text up )
bot prevchar nextchar bot to bot bor to ( reset bot correctly )
cc @ptr ( gap) e8 @ptr ( text) - text + gap to ( set gap )
d4 @ptr ( beot ) d0 @ptr ( bou ) - bou + beot to
beot eos to
cc @ptr ( gap ) d8 @ptr ( bos ) - gap swap - bos to
[ .s/r 100 + ] literal idtable 80 move dirtytext? on
parksafe err or doff ( leave error flag on stack )
if text 8 0d fill text 8 + bot to ( re-initialize the beginning of text )
#defaults #itbl esize move
text #itbl %wr + ! ( set the start of text correctly )
#defaults #ctrl esize move
text #ctrl %wr + ! ( and in the control variables too )
bot makedefdpkt
endtext 20 - dpktsize - addr to addr endtext addr - rtn fill
addr makedefdpkt addr nextchar eot to
bot ( scan text -> gap )
begin dup gap < while gap verifychar gap to again
beot
begin dup eot < while eot verifychar addr to again
beot dup eot addr - + addr beot - move ( move end of text into place )
beot eot addr - + beot to beot eos to ( and reset beot )
then
preset bot eot 1+ killivls
eot eor to ( make sure in global mode )
fixcalcs ( see calc package ) rtn encalc endtext 3 - ! ( for recalc )
( dc @ptr if wonb else bonw then ( reset screen before displaying )
new-display
bos nextchar eos = if widecursor else extendedcursor then
resetphonelight checklocallight rule ;
: t. <# #s #> type ;
: sho local adr adr to
." wr=" %wr adr + @ dup -1 = if abs t. exit then
dup 0< if 80000000 + 2d emit 2d emit then t.
." pg=" %pg adr + @ t.
." pgl=" %pgl adr + @ t.
." ln=" %ln adr + @ t. ." lnl=" %lnl adr + w@ t.
." spr=" %spr adr + c@ t. ." lsp=" %lsp adr + c@ t.
." le=" %left adr + c@ t. ." wi=" %wide adr + c@ t.
." in=" %indent adr + c@ t. ;
: ww do cr i t. space i esize * #wtable + sho loop cr ;
: wws lastline 1+ 0 ww ;
: pp do cr i t. space i esize * #itbl + sho loop cr ;
: pps endtext text - isize / 1+ 0 pp ;
: csho #ctrl sho ;
: notimplemented beep ;
: setlearn ( string# -- | set which string to use for learn )
dup 0 #learns 1- inrange not
abort" Invalid Learn string specified" curlearn to ;
: learnsize ( -- big | maximum size of a learn string )
maxlearn needforth ( see if max size is availible )
if maxlearn then ; ( if so, use it, else set to availible size )
: newlearn ( string# -- | init for recording a learn )
setlearn
thislearn drop learnsize thislearn "to
learnpos off
learning? on
learnbuff on ;
: newplayback ( string# -- | init for playing back a learn )
local formats? formats? off ( true if phrase has formats in it )
setlearn
thislearn drop @ ( see if the first entry is 0 )
if modifiers off
learnpos off
learnbuff on
learning? off
else " " 1 indicate ( turn off the indicator first )
gap prevchar dup c@ ds = ( if char is a doc )
if narrowcursor? not ( if a wide or extended cursor )
beot eor <> and ( and not at end of text )
if nextchar then then ( then advance to check beot )
findchar #lock c@ lok = ( are we allowed to change here? )
if lockedtext error exit then ( if not, say so and do nothing )
thislearn pktsize 2* + needtext outofroom drop ( see if enough room )
thislearn drop 4 + learnpos to ( this is where the phrase starts )
learnpos c@ &fmt = ( if phrase starts with a packet )
if rtn workpkt c! ( a pseudo-break )
learnpos workpkt 1+ pktsize move ( copy packet to workpkt )
pktsize learnpos +to ( and move learnpos past that point )
gap prevbrk fpkt? not ( if no packet on previous break )
if gap prevbrk dup findchar ( find format there )
brk+ pktsize makespace ( and make a packet )
makepkt
then
gap prevbrk ( now there is a packet )
workpkt <swappkt> ( swap in the work packet )
formats? on ( flag saying we have a format )
then
forceop on ( so that op is set correctly )
learnpos thislearn + over - insertblock ( now insert the phrase )
formats? ( if phrase has breaks in it )
if gap prevbrk workpkt <swappkt> then ( swap onto last brk in phrase )
gap prevchar bos to preset ( now display the selection )
redisplay widecursor
clearundo savepos workpkt pktsize 0 fill ( for undo )
['] removeselection undop to ( this is how to undo this )
then ;
code numberkeys nx ) jsr, ;c ( an array with scancodes for digits )
21 c, ( 0 )
28 c, ( 1 )
20 c, ( 2 )
10 c, ( 3 )
8 c, ( 4 )
0 c, ( 5 )
1 c, ( 6 )
9 c, ( 7 )
11 c, ( 8 )
19 c, ( 9 )
: #key? ( scancode -- f|ascii t )
0a 0 ( there are 10 digits )
do i numberkeys + c@ over = ( if the scancode is in numberkeys )
if drop i -1 exit then ( return the value and a true )
loop drop 0 ; ( else, not a number key )
: showlearn ( number -- )
ascii 0 + ascii 9 min ascii 0 max indlearn# ;
: Learn ( -- | stops learn or playback & sets flag )
local oldbos ( we need to remember the bos )
learnbuff ( if we are learning )
if clearlearn
learnpos 8 > not ?extended and ( if there wasn't something recorded)
if clearundo ( clear out undo first )
selsize pktsize 2* + ( size we could possibly need )
dup applic here - > ( see if enough space in forth )
swap bou gap - 5 - > or ( and in the text )
if noroom error abort then ( if not in both, then can't do it )
0 gap 5 + ! ( flag for phrase storage )
gap 9 + learnpos to ( this is how much we've recorded )
bos gap firstbreak ( if there is a break in the selection )
if bos findchar learnpos makepkt ( make a packet to start out )
pktsize learnpos +to ( and add to size of copy )
then
bos oldbos to ( hold bos as popsep? can change it )
bos learnpos selsize insertcopy learnpos to ( copy selection )
oldbos bos to ( restore bos )
bos gap firstbreak ( if there is a break in the selection )
if gap 5 + learnpos lastbreak ( force a packet on last break )
dup fpkt? ( if already a packet )
if drop ( then done )
else brk+ ( advance to next char )
dup learnpos over - over pktsize + swap move ( make hole )
pktsize learnpos +to ( and increase size )
makepkt ( make a random packet here )
then
then
gap 5 + learnpos over - thislearn "to ( assign it )
collapse widecursor ( collapse selection now )
then
else ascii ? indlearn# rule ( else, indicate are about to learn)
waitkey ( wait for a key )
scancode #key? ( peek ahead to see if a digit )
if <key> drop ( if it was, get the key and toss it )
clear-shifts sync-shiftkeys ( and clear all shift keys )
0 toshiftlock ( force the shiftlock off here )
dup newlearn ( and start the recording )
showlearn ( put up the learn number in ruler )
else 0 0 1 indicate then ( otherwise, turn off indicator )
then undop off clear-auto ; ( can't undo this, and don't repeat )
: lrncmd ( buffer number -- | handle learn keys )
learning? ( see if need to close down buffer )
if thislearn drop learnpos thislearn "to ( close down buffer )
learnbuff off learning? off learnpos off ( turn off all the learning now)
then
dup showlearn ( put the learn number up in ruler )
newplayback
undop off clear-auto ;
: 0-cmd ( -- | set this buffer as the learn/playback buffer )
0 lrncmd ;
: 1-cmd 1 lrncmd ;
: 2-cmd 2 lrncmd ;
: 3-cmd 3 lrncmd ;
: 4-cmd 4 lrncmd ;
: 5-cmd 5 lrncmd ;
: 6-cmd 6 lrncmd ;
: 7-cmd 7 lrncmd ;
: 8-cmd 8 lrncmd ;
: 9-cmd 9 lrncmd ;
: initcalc ( -- )
rtn encalc endtext 3 - ! ( so recalc will work )
0 hidebyte dup dup 10 shl or endtext ! endtext 4 + w!
['] arithmetic <empty> ; ( no naming collisions )
: cleanedde ( cleans up edde when a character is typed in a new text )
initcalc eraselist off ( clean up any lost calcs )
clearundo
idtable 80 0 fill ( force the text to be different from disk )
forceop on cursor? on ; ( and make sure the cursor will blink )
( tlh 6/28:12:57 )
: initedde top text to ( initialize where the text is located )
ramend 28 - dup text - isize mod - 20 + endtext to
btable 100 -1 fill btable 20 + 0a0 0 fill 0 btable 0d + c! ( init btable )
initruler text 8 0d fill text 8 + bot to ( bot bos to )
#itbl [ itblsize ] literal -1 fill #defaults #itbl esize move
text #itbl %wr + ! ( set the start of text correctly )
#defaults #ctrl esize move
text #ctrl %wr + ! ( and in the control variables too )
bot dpktsize + gap to bot makedefdpkt
bot bos to
endtext 20 - dpktsize - beot to beot endtext beot - rtn fill
beot makedefdpkt
preset beot eos to beot nextchar eot to
bot bor to eot eor to ( set up range for global searching )
bot op to op pop to
endtext text - isize / 1+ esize * #itbl + endtextivl to wraplim off
10 firstseen to 3b lastseen to 4e lastline to 14 middle to
text knownplace topline off
firstseen 2+ lines to 2 pages to dirtytext? off firstseen gapline to
rewindow
targeting 0=
if clearlearn #learns 0 do " " i setlearn thislearn "to loop ( init learns )
initcalc eraselist off ( and init calcs to )
then
clearundo
idtable 80 0 fill
1 cstate to forceop on cursor? on norefresh off
checkline# checkgauge checkbattery ;
( explain and extended explain messages )
t' stylemsg 2 xpln! ( t )
t' printmsg 4 xpln! ( j )
t' explainmsg 7 xpln! ( n )
t' spacingmsg b xpln! ( u )
t' diskmsg d xpln! ( l )
t' sortmsg e xpln! ( , )
t' calcmsg 14 xpln! ( g )
t' learnmsg 17 xpln! ( v )
t' capsmsg 1a xpln! ( e )
t' addspellmsg 1b xpln! ( o )
t' phonemsg 1d xpln! ( ' )
t' boldmsg 22 xpln! ( w )
t' controlmsg 24 xpln! ( d )
t' localmsg 27 xpln! ( x )
t' marginmsg 29 xpln! ( - )
t' underlinemsg 2a xpln! ( q )
t' setupmsg 2b xpln! ( 1/2 )
t' sendmsg 2d xpln! ( return )
t' marginmsg 31 xpln! ( = )
t' tabmsg 32 xpln! ( tab )
t' copymsg 34 xpln! ( a )
t' kbdmsg 35 xpln! ( / )
t' leapmsg 36 xpln! ( left leap )
t' marginmsg 38 xpln! ( +/- )
t' undomsg 39 xpln! ( undo )
t' erasemsg 3b xpln! ( erase )
t' lockmsg 3c xpln! ( lock )
t' titlemsg 3d xpln! ( page )
t' leapmsg 3e xpln! ( right leap )
code <explain> ( limit addr -> limit addr' | Move the characters from the
string at addr to the line buffer start. Exit if cr encountered or if at
string or buffer limit. Return the limit and the the updated string addrerss.)
lbuff #n a0 move, sp )+ a1 move, sp ) d1 move,
markbl 8 shl #n d0 .w move, d0 a0 )+ .w move, a0 )+ .w clr,
a0 -4 )d a0 )+ move, ( clear first 2 chars )
begin, 0 #n d0 moveq, a1 )+ d0 .b move, ( clear register & load character)
rtn #n d0 .w cmp, gt ( is it not a break?)
while, a1 d1 cmp, ge ( not at string end?)
while, d0 a0 )+ .b move, ( copy char to lbuff )
a1 ) d0 .b move, d0 d2 .b move, ( attribute byte? )
&firsthid &attr or #n d2 .b and, &attr #n d2 .b cmp, eq
if, 07 #n d0 .b and, 1 #n d0 asl, d0 a0 )+ .b move, ( yes )
1 #n a1 addq, a1 ) d0 .b move,
else, a0 )+ .b clr, ( no attr byte )
then, a0 )+ .b clr, ( 3rd byte always 0)
d0 d2 .b move, &firsthid #n d2 .b and, ( copy & mask)
&firstacc #n d2 .b cmp, eq ( is it an accent? )
if, d0 a0 )+ .b move, 1 #n a1 addq, ( yes )
else, a0 )+ .b clr, ( no accent )
then, lbuff &horiz lbufwide * + #n a0 cmp, eq ( end of line? )
until, a1 sp -) move, $end #n a0 -3 )d .b or, next;
: extexpl ( addr len -> | Display the explain screen at addr for len and then
wait and display any extended explain screens that the user desires)
local lastexpl clear-auto ( no auto repeat during explain display)
begin over lastexpl to ( to avoid repeat messages )
cls over + swap ( clear screen, stack limit & addr)
32 0 do <explain> i disp 2 +loop ( display explain message, update addr)
2drop ( limit & final updated address)
begin ( extended explain loop)
begin waitkey ( get the next key )
?ctl not if exit then ( exit if use front goes up )
<key> drop scancode ( else, get the real scancode )
2* xplntbl + w@ ?dup ( get token of message or 0 )
until execute ( get corresp extended explain msg )
over lastexpl = ( ignore repeat messages )
while 2drop ( drop the addr and len )
again
again ;
: Expl ( -- )
lastop %explain <>
if defaultmsg xplen to xplint to then
xplint xplen extexpl
lastseen 1+ firstseen do i update! loop refresh
resetcursor
lastop %explain = if %explain curop to then ;
( Print command tables 26feb87/dab )
: fx80magic ( addr char -- \ handle fancy font switches for FX80 )
<"> [ 2 c, 1b c, ascii R c, ] put" <printc> ( switch to a country )
1+ c@ <printc> ( print a char there )
<"> [ 3 c, 1b c, ascii R c, 00 c, ] put" ( back to the good ol' USA )
;
code fx80.printer nx ) jsr, ;c ( a ROM array)
( the pure ascii print code table)
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
( 32 blanks for 00-1F)
spc w, ch ! ch " " #$%&'()*+,-./" ,chars ( chars 20-2F)
" 0123456789:;<=>?" ,chars ( chars 30-3F)
" @ABCDEFGHIJKLMNO" ,chars ( chars 40-4F)
" PQRSTUVWXYZ[\]^_" ,chars ( chars 50-5F)
" `abcdefghijklmno" ,chars ( chars 60-6F)
" pqrstuvwxyz{|}~" ,chars ( chars 70-7E)
os ^- ( triangle) os ,C ( Cedilla) XXX ( no plus-minus)
XXX ( no ||) 045c w, ( O-slash) 047c w, ( o-slash)
027e w, ( Beta) 047d w, ( a-dot) 015c w, ( cedilla)
ch L ( no L-dot) ch l ( no l-dot) XXX ( no B-%)
XXX ( no B-s) ch n ( was 'n) ch N ( was 'N)
XXX ( no script-l) 045d w, ( A-dot) ( chars 7F-8F)
015b w, ( degrees) 047b w, ( ae) 045b w, ( AE)
XXX ( perm space) XXX ( no para) 015d w, ( section)
XXX ( no 1/8) XXX ( no 3/8) XXX ( no 5/8)
XXX ( no 3/4) XXX ( no 7/8) os |c ( cents)
0323 w, ( sterling) 085c w, ( Yen) 0723 w, ( Pt)
XXX ( no scr-f) ( chars 90-9F)
XXX ( no TM) XXX ( no circ-r) XXX ( no circ-c)
os -| ( dagger) XXX ( super-2 ) XXX ( super-3 )
os _a ( a-dash) os _o ( o-dash) 075d w, ( leading ?)
os -: ( divide) XXX ( os space) XXX ( no 1/2)
XXX ( no 1/4) 075b w, ( leading-!) XXX ( no <<)
XXX ( no >>) ( chars A0-AF)
ch ' ( lc ague) ch ` ( lc grave) ch ^ ( lc circumflex)
017e w, ( lc umlaut) ch _ ( was dbl-ul) XXX ( no bare dots)
ch ~ ( lc tilde) ch - ( strikeout) ch ^ ( lc curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars B0-BF)
ch ' ( uc ague) ch ` ( uc grave) ch ^ ( uc circumflex)
017e w, ( uc umlaut) ch _ ( was dbl-ul) spc w, ( was os dots)
ch ~ ( uc tilde) ch - ( strikeout) ch ^ ( uc curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars C0-CF)
os 'A 0540 w, ( A E )
" IOU" ascii ' ,accents ( ague accent on AEIOU )
os 'a 065d w, ( a e )
" iou" ascii ' ,accents ( ague accents on aeiou )
" AEIOU" ascii ` ,accents ( grave accents on AEIOU )
0140 w, 017d w, 067e w, ( a e i )
067c w, 017c w, ( o u ) ( grave accents on aeiou )
" AEIOUaeiou" ascii ^ ,accents ( circumflex accents on AEIOUaeiou )
025b w, c345 w, c349 w, ( A E I )
025c w, 025d w, ( O U ) ( umlauts on AEIOU )
027b w, b365 w, b369 w, ( a e i )
027c w, 027d w, ( o u ) ( umlauts on aeiou )
075c w, 077c w, ( N and n with tilde )
c359 w, b379 w, ( Y and y with umlaut )
" AaOo" ascii ~ ,accents ( funny Danish A & O - tilde )
" AEIOUaeiou" ascii ^ ,accents ( curved circ on vowels)
cr ." FX80 printer table is" here target - tc' fx80.printer 2+ - 2/ .
." entries. "
( Daisy Wheel skeleton printer table 29June87/dab)
: daisymagic ( addr char -- \ handle weirdprint for daisywheels )
drop 1b <printc> 1+ c@
printercode 3 < if ( Cat180 or NewAP) ascii Y
else ( AP1/3/400 ) ascii O then
+ <printc> 2 motion ;
code daisy.printer nx ) jsr, ;c ( a ROM array)
( the skeleton for the daisy wheel printer table )
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
( 32 blanks for 00-1F)
spc w, ch ! ch " " $%&'()*+,-./" ,chars ( chars 20-2F)
" 0123456789:; = ?" ,chars ( chars 30-3F)
" ABCDEFGHIJKLMNO" ,chars ( chars 40-4F)
" PQRSTUVWXYZ " ,chars ( chars 50-5D)
b220 w, ( clever way of printing up-arrow when available ) ( char 5E)
ch _ ( char 5F )
" abcdefghijklmno" ,chars ( chars 60-6F)
" pqrstuvwxyz " ,chars ( chars 70-7E)
XXX ( no triangle) ch C ( Cedilla) XXX ( no plus-minus)
XXX ( no ||) os /O ( O-slash) os /o ( o-slash)
XXX ( no Beta) ch a ( was a-dot) ch c ( cedilla)
ch L ( L-dot) ch l ( l-dot) XXX ( no B-%)
XXX ( no B-s) ch n ( 'n) ch N ( 'N)
XXX ( no script-l) ch A ( A-dot) ( chars 7F-8F)
XXX ( no degrees) XXX ( no ae) XXX ( no AE)
XXX ( perm space) XXX ( no para) XXX ( no section)
XXX ( no 1/8) XXX ( no 3/8) XXX ( no 5/8)
XXX ( no 3/4) XXX ( no 7/8) os /c ( cents)
XXX ( no lbs) os =Y ( Yen) XXX ( no Pt)
XXX ( no scr-f) ( chars 90-9F)
XXX ( no TM) XXX ( no circ-r) XXX ( no circ-c)
XXX ( no dagger) ch 2 ( super 2 ) ch 3 ( super 3 )
os _a ( a-dash) os _o ( o-dash) XXX ( no leading ?)
XXX ( no divide) XXX ( os space) XXX ( no 1/2)
XXX ( no 1/4) XXX ( no leading-!) XXX ( no <<)
XXX ( no >>) ( chars A0-AF)
XXX ( no ague) XXX ( no grave) XXX ( no circumflex)
XXX ( no umlaut) ch _ ( was dbl-ul) XXX ( no bare dots)
XXX ( no tilde) ch - ( strikeout) XXX ( no curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars B0-BF)
XXX ( no ague) XXX ( no grave) XXX ( no circumflex)
XXX ( no umlaut) ch _ ( was dbl-ul) XXX ( no os dots)
XXX ( no tilde) ch - ( strikeout) XXX ( no curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars C0-CF)
" AEIOU" c0 ,accents
" aeiou" b0 ,accents ( ague accents on vowels)
" AEIOU" c1 ,accents
" aeiou" b1 ,accents ( grave accents on vowels)
" AEIOU" c2 ,accents
" aeiou" b2 ,accents ( circumflex accents on vowels)
" AEIOU" c3 ,accents
" aeiou" b3 ,accents ( umlauts on vowels)
c64e w, b66e w, ( tildes on N's)
c359 w, b379 w, ( umlauts on Y's)
c641 w, b661 w, ( tildes on A's )
c64f w, b66f w, ( tildes on O's )
" AEIOU" c8 ,accents
" aeiou" b8 ,accents ( curved circ on vowels)
cr ." Daisywheel printer table is" here target - tc' daisy.printer 2+ -
dup printsize to
2/ . ." entries. "
code norway.dw nx ) jsr, ;c
0023 w, 9c c, ( sterling )
003c w, 3c c, ( less than )
003e w, 3e c, ( greater than )
0040 w, b0 c, ( lc ague accent )
0040 w, c0 c, ( also uc ague accent )
005b w, 92 c, ( AE )
005c w, 83 c, ( O-slash ??? )
005d w, 8f c, ( A-dot )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, b1 c, ( lc grave accent )
0060 w, c1 c, ( also uc grave accent )
007b w, 91 c, ( ae )
007c w, 84 c, ( o-slash )
007d w, 86 c, ( a-circle )
007e w, b3 c, ( lc umlaut )
007e w, c3 c, ( also uc umlaut )
0100 w, 7c c, ( vertical bar )
0101 w, 95 c, ( section )
-1 w, ( End of Norway/Denmark daisy exceptions )
code holland.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 3c c, ( less than )
003e w, 3e c, ( greater than )
0040 w, 7c c, ( vertical bar )
005b w, b0 c, ( lc ague accent )
005b w, c0 c, ( also uc ague accent )
005c w, b3 c, ( lc umlaut )
005c w, c3 c, ( uc umlaut )
005d w, b1 c, ( lc grave accent )
005d w, c1 c, ( uc grave accent )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
007b w, 9f c, ( script-f )
007c w, 81 c, ( plus/minus )
007d w, ab c, ( 1/2 )
007e w, 7e c, ( tilde )
007e w, b6 c, ( also lc tilde )
007e w, c6 c, ( also uc tilde )
0100 w, 9c c, ( sterling )
0101 w, 95 c, ( section )
-1 w, ( End of Netherlands daisy exceptions )
code afrikaans.dw nx ) jsr, ;c
0023 w, 8e c, ( script-l )
003c w, a4 c, ( less than )
003e w, a5 c, ( greater than )
0040 w, 40 c, ( at-sign )
005b w, b0 c, ( lc ague accent )
005b w, c0 c, ( also uc ague accent )
005c w, b3 c, ( lc umlaut )
005c w, c3 c, ( uc umlaut )
005d w, b1 c, ( lc grave accent )
005d w, c1 c, ( uc grave accent )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
007b w, 8c c, ( 'n )
007c w, 7c c, ( vertical bar )
007d w, ab c, ( 1/2 )
007e w, a9 c, ( divide )
0100 w, b4 c, ( double underline )
0100 w, c4 c, ( also uc double underline )
0101 w, 95 c, ( section )
-1 w, ( End of South African daisy exceptions )
code latin.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 8b c, ( B-s )
003e w, 8a c, ( B-% )
0040 w, 7c c, ( vertical bar )
005b w, f8 c, ( Ennye )
005c w, ad c, ( leading exclamation )
005d w, b0 c, ( lc ague accent )
005d w, c0 c, ( uc ague accent )
005e w, b3 c, ( lc umlaut )
005e w, c3 c, ( uc umlaut )
0060 w, 82 c, ( double bar )
007b w, f9 c, ( ennye )
007c w, a8 c, ( leading ? )
007d w, a6 c, ( super-a )
007e w, a7 c, ( super-o )
0100 w, b4 c, ( double underline )
0100 w, c4 c, ( also double underline )
0101 w, b5 c, ( dots )
0101 w, c5 c, ( dots )
-1 w, ( End of Latin America daisy exceptions )
code spain.dw nx ) jsr, ;c
0023 w, 7c c, ( vertical bar )
003c w, a6 c, ( super-a )
003e w, a7 c, ( super-o )
0040 w, b0 c, ( lc ague accent )
0040 w, c0 c, ( uc ague accent )
005b w, f8 c, ( Ennye )
005c w, ad c, ( leading exclamation )
005d w, 80 c, ( Cedilla )
005e w, b4 c, ( double underline )
005e w, c4 c, ( also double underline )
0060 w, b3 c, ( lc umlaut )
0060 w, c3 c, ( uc umlaut )
007b w, f9 c, ( ennye )
007c w, a8 c, ( leading-? )
007d w, 87 c, ( cedilla )
007e w, b1 c, ( lc grave accent )
007e w, c1 c, ( also uc grave accent )
0100 w, 88 c, ( L-dot )
0101 w, 89 c, ( l-dot )
-1 w, ( End of Spain daisy exceptions )
code sweden.dw nx ) jsr, ;c
0023 w, 95 c, ( section )
003c w, 3c c, ( less than )
003e w, 3e c, ( greater than )
0040 w, b0 c, ( lc ague accent )
0040 w, c0 c, ( uc ague accent )
005b w, ee c, ( A-umlaut )
005c w, f1 c, ( O-umlaut )
005d w, 8f c, ( A-circle )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
9061 w, 86 c, ( circle-a )
0060 w, b1 c, ( lc grave accent )
0060 w, c1 c, ( also uc grave accent )
007b w, f3 c, ( a-umlaut )
007c w, f6 c, ( o-umlaut )
007d w, 86 c, ( a-circle )
007e w, f7 c, ( u-umlaut )
0100 w, 7c c, ( vertical bar )
0101 w, 9c c, ( sterling )
-1 w, ( End of Sweden daisy exceptions )
code usa.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, a4 c, ( super 2 )
003e w, a5 c, ( super 3 )
0040 w, 40 c, ( @ sign )
005b w, 5b c, ( left bracket )
005c w, 81 c, ( plus/minus )
005d w, 5d c, ( right bracket )
005e w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
0060 w, 9b c, ( cents )
007b w, ac c, ( 1/4 )
007c w, 7c c, ( vert bar )
007d w, ab c, ( 1/2 )
007e w, b4 c, ( double uline )
007e w, c4 c, ( double uline also )
0100 w, 94 c, ( paragraph )
0101 w, 95 c, ( section )
-1 w, ( End of USA daisy exceptions )
code special.dw ;c
code ascii.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 3c c, ( less than )
003e w, 3e c, ( greater than )
0040 w, 40 c, ( @ sign )
005b w, 5b c, ( left bracket )
005c w, 5c c, ( backslash )
005d w, 5d c, ( right bracket )
005e w, 5e c, ( up-arrow )
005e w, b2 c, ( also lc circumflex )
005e w, c2 c, ( also uc circumflex )
0060 w, 60 c, ( back-tick )
0060 w, b1 c, ( also lc accent grave )
0060 w, c1 c, ( also uc accent grave )
007b w, 7b c, ( left brace )
007c w, 7c c, ( vert bar )
007d w, 7d c, ( right brace )
007e w, 7e c, ( tilde )
007e w, b6 c, ( also lc tilde )
007e w, c6 c, ( also uc tilde )
0100 w, 94 c, ( paragraph )
0101 w, 95 c, ( section )
-1 w, ( End of ASCII daisy exceptions )
code qume.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 3c c, ( super 2 )
003e w, 3e c, ( super 3 )
0040 w, 40 c, ( @ sign )
005b w, 5b c, ( left bracket )
005c w, a3 c, ( dagger )
005d w, 5d c, ( right bracket )
005e w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
0060 w, a0 c, ( trademark )
007b w, a1 c, ( registered TM )
007c w, 7c c, ( vert bar )
007d w, a2 c, ( copyright )
007e w, b4 c, ( double uline )
007e w, c4 c, ( double uline also )
0100 w, 94 c, ( paragraph )
0101 w, 95 c, ( section )
-1 w, ( End of WP-Qume daisy exceptions )
code portugal.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 3c c, ( less than )
003e w, 3e c, ( greater than )
0040 w, 40 c, ( @ sign )
005b w, 5b c, ( left bracket )
005c w, 5c c, ( backslash )
005d w, 5d c, ( right bracket )
005e w, b2 c, ( lc curcumflex )
005e w, c2 c, ( also uc circumflex )
0060 w, b1 c, ( lc grave )
0060 w, c1 c, ( also uc grave )
007b w, 7b c, ( left brace )
007c w, 7c c, ( vert bar )
007d w, 7d c, ( right brace )
007e w, 7e c, ( tilde )
007e w, b6 c, ( also lc tilde accent )
007e w, c6 c, ( also uc tilde accent )
0100 w, 82 c, ( double bar )
0101 w, 9c c, ( sterling )
-1 w, ( End of Portugal daisy exceptions )
code uk.dw nx ) jsr, ;c
0023 w, 9c c, ( sterling )
003c w, ac c, ( 1/4 )
003e w, 99 c, ( 3/4 )
0040 w, 40 c, ( @ sign )
005b w, 5b c, ( left bracket )
005c w, ab c, ( 1/2 )
005d w, 5d c, ( right bracket )
005e w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
0060 w, 96 c, ( 1/8 )
007b w, 97 c, ( 3/8 )
007c w, 7c c, ( vert bar )
007d w, 98 c, ( 5/8 )
007e w, 9a c, ( 7/8 )
0100 w, b4 c, ( double underline )
0100 w, c4 c, ( also double underline )
0101 w, 82 c, ( double bar )
-1 w, ( End of United Kingdom daisy exceptions )
code german.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, b0 c, ( lc ague accent )
003c w, c0 c, ( also uc ague accent )
003e w, b1 c, ( lc grave accent )
003e w, c1 c, ( also uc grave accent )
0040 w, 95 c, ( section )
005b w, ee c, ( A-umlaut )
005c w, f1 c, ( O-umlaut )
005d w, f2 c, ( U-umlaut )
005e w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
0060 w, 7c c, ( vertical bar )
007b w, f3 c, ( a-umlaut )
007c w, f6 c, ( o-umlaut )
007d w, f7 c, ( u-umlaut )
007e w, 85 c, ( Beta )
0100 w, a4 c, ( super 2 )
0101 w, a5 c, ( super 3 )
-1 w, ( End of West Germany daisy exceptions )
code italy.dw nx ) jsr, ;c
0023 w, 9c c, ( sterling )
003c w, 7c c, ( vertical bar )
003e w, ab c, ( 1/2 )
0040 w, 95 c, ( section )
005b w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
005c w, 87 c, ( cedilla )
005d w, d6 c, ( e-ague )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, e3 c, ( u-grave )
007b w, df c, ( a-grave )
007c w, e2 c, ( o-grave )
007d w, e0 c, ( e-grave )
007e w, e1 c, ( i-grave )
0100 w, b4 c, ( double underline )
0100 w, c4 c, ( also double underline )
0101 w, 82 c, ( double bar )
-1 w, ( End of Italy daisy exceptions )
code france.dw nx ) jsr, ;c
0023 w, 9c c, ( sterling )
003c w, a4 c, ( super 2 )
003e w, a5 c, ( super 3 )
0040 w, df c, ( a-grave )
005b w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
005c w, 87 c, ( cedilla )
005d w, 95 c, ( section )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, 7c c, ( vertical bar )
007b w, d6 c, ( e-ague )
007c w, e3 c, ( u-grave )
007d w, e0 c, ( e-grave )
007e w, b3 c, ( lc umlaut )
007e w, c3 c, ( also uc umlaut )
0100 w, ab c, ( 1/2 )
0101 w, 82 c, ( double bar )
-1 w, ( End of French daisy exceptions )
code swiss.dw nx ) jsr, ;c
0023 w, 9c c, ( sterling )
003c w, b0 c, ( lc ague accent )
003c w, c0 c, ( also uc ague accent )
003e w, b1 c, ( lc grave accent )
003e w, c1 c, ( also uc grave accent )
0040 w, df c, ( a-grave )
005b w, d6 c, ( e-ague )
005c w, e0 c, ( e-grave )
005d w, e3 c, ( u-grave )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, 7c c, ( vertical bar )
007b w, f3 c, ( a-umlaut )
007c w, f6 c, ( o-umlaut )
007d w, f7 c, ( u-umlaut )
007e w, b3 c, ( lc umlaut )
007e w, c3 c, ( also uc umlaut )
0100 w, 87 c, ( cedilla )
0101 w, 95 c, ( section )
-1 w, ( End of Switzerland daisy exceptions )
code japan.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, 90 c, ( degrees )
9061 w, 86 c, ( circle-a )
003e w, b4 c, ( double underline )
003e w, c4 c, ( also double underline )
0040 w, 40 c, ( @ sign )
005b w, b0 c, ( lc ague accent )
005b w, c0 c, ( also uc ague accent )
005c w, b3 c, ( lc umlaut )
005c w, c3 c, ( also uc umlaut )
005d w, b1 c, ( lc grave accent )
005d w, c1 c, ( also uc grave accent )
005e w, b2 c, ( lc circumflex )
005e w, c2 c, ( also uc circumflex )
005e w, b8 c, ( also lc curved circumflex )
005e w, c8 c, ( also uc curved circumflex )
0060 w, 9d c, ( Yen )
007b w, 95 c, ( section )
007c w, 7c c, ( vert bar )
007d w, 87 c, ( cedilla )
007e w, 85 c, ( Beta )
0100 w, 94 c, ( paragraph )
0101 w, 9c c, ( sterling )
-1 w, ( End of Japan daisy exceptions )
code canada.dw nx ) jsr, ;c
0023 w, 23 c, ( sharp sign )
003c w, ab c, ( 1/2 )
003e w, ac c, ( 1/4 )
0040 w, c2 c, ( uc circumflex )
0040 w, c8 c, ( also uc curved circumflex )
005b w, c0 c, ( uc ague accent )
005b w, b0 c, ( also lc ague )
005c w, c3 c, ( uc umlaut )
005d w, c1 c, ( uc grave accent )
005e w, b2 c, ( lc circumflex )
005e w, b8 c, ( also lc curved circumflex )
0060 w, b1 c, ( lc grave accent )
007b w, d6 c, ( e ague is a distinct character! )
007c w, 7c c, ( vertical bar )
007d w, b3 c, ( lc umlaut )
007e w, 87 c, ( cedilla )
0100 w, b4 c, ( double underline )
0100 w, c4 c, ( also double underline )
0101 w, 9b c, ( cents )
-1 w, ( end of Canada daisy exceptions )
code DW.countries ( -- addr \ table of tokens of tables of exeptions! )
nx ) jsr, ;c
t' usa.dw w, t' canada.dw w, t' latin.dw w, t' norway.dw w,
t' sweden.dw w, t' holland.dw w, t' german.dw w, t' swiss.dw w,
t' france.dw w, t' uk.dw w, t' spain.dw w, t' italy.dw w,
t' special.dw w, t' japan.dw w,
( LBP printer tables, magic code 1Jul87/dab&pb)
code countries nx ) jsr, ;c ( ROM table maps weird chars -> country)
8701 w, ( IBM1, must shift back )
8702 w, ( IBM2, must shift back )
642 w, ( USA )
641 w, ( UK )
645 w, ( Norway/Denmark )
64A w, ( Japan )
632 w, ( Netherlands )
742 w, ( IBM1 low half)
652 w, ( France )
633 w, ( Switzerland )
64b w, ( West Germany )
630 w, ( Canada )
: setcountry ( country# -- \ set the LBP to a country )
dup oldcountry = if drop else dup oldcountry to
<# 10 /mod swap 30 + hold
2 0 do 10 /mod swap 20 + hold loop drop
<"> [ 2 c, 1b c, ascii ) c, ] "hold 0 #>
put" hmi" put" then ;
: LBPmagic ( addr char -- \ handle weirdprint for LBP printer table )
dup 1d > if ( a 'funny' country? )
1e = if 642 else 641 then setcountry
<"> [ 4 c, 0e c, 1b c, ascii : c, 1b c, ] put"
1+ c@ <printc>
<"> [ 3 c, 1b c, ascii ; c, 0f c, ] put"
else
1- 2* countries + w@
dup setcountry swap 1+ c@ <printc> 2 motion
8000 and if
<"> [ 3 c, 1b c, ascii ) c, 42 c, ] put"
oldcountry off hmi" put" then
then ;
code LBP.printer nx ) jsr, ;c ( a ROM array )
( printer code table for Laser Beam Printer )
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
( 32 blanks for 00-1F)
spc w, ch ! ch " " #$%&'()*+,-./" ,chars ( chars 20-2F)
" 0123456789:;<=>?" ,chars ( chars 30-3F)
" @ABCDEFGHIJKLMNO" ,chars ( chars 40-4F)
" PQRSTUVWXYZ[\]^_" ,chars ( chars 50-5F)
" `abcdefghijklmno" ,chars ( chars 60-6F)
" pqrstuvwxyz{|}~" ,chars ( chars 70-7E)
08ff w, ( del char) 0180 w, ( Cedilla) 03dc w, ( plus-minus)
1f5a w, ( ||) 05dc w, ( O-slash) 05fc w, ( o-slash)
( ^^^ strange LBPmagic juju)
06fe w, ( Beta) 05fd w, ( a-dot) 06fd w, ( cedilla)
029e w, ( L-dot) 029f w, ( l-dot) XXX ( no B-%)
XXX ( no B-s) 02ac w, ( 'n) ch N ( was 'N)
02ab w, ( script-l) 05dd w, ( A-dot) ( chars 7F-8F)
03de w, ( degrees) 05fb w, ( ae) 05db w, ( AE)
spc w, ( perm space) 1e59 w, ( para) 1e5a w, ( section)
( note more strange juju intertwined with LBPmagic )
04e0 w, ( 1/8) 04fb w, ( 3/8) 04fd w, ( 5/8)
04be w, ( 3/4 ) 04fe w, ( 7/8) 03e0 w, ( cents)
04a3 w, ( lbs) 06e0 w, ( Yen) 019e w, ( Pt)
07fb w, ( scr-f) ( chars 90-9F)
XXX ( no TM) XXX ( no circ-r) XXX ( no circ-c)
XXX ( dagger) 03bc w, ( 2 super) 03be w, ( 3 super )
01a6 w, ( a-dash) 01a7 w, ( o-dash) 01a8 w, ( leading ?)
01f6 w, ( divide) spc w, ( os space) 03fd w, ( 1/2)
03fb w, ( 1/4) 01ad w, ( leading-!) 01ae w, ( <<)
01af w, ( >>) ( chars A0-AF)
0cdb w, ( lc ague) 0ce0 w, ( lc grave) 0cde w, ( lc circumflex)
0cfd w, ( lc umlaut) 03fe w, ( dbl-ul) 01b0 w, ( bare dots)
07fe w, ( tilde) 01c4 w, ( strikeout) 0cde w, ( lc curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars B0-BF)
0cdb w, ( ague) 0cdd w, ( uc grave) 0cc0 w, ( uc circumflex)
0cdc w, ( uc umlaut) 03fe w, ( dbl-ul) 01b0 w, ( bare dots)
07fe w, ( tilde) 01c4 w, ( strikeout) 0cc0 w, ( uc curved circ.)
XXX XXX XXX
XXX XXX XXX
XXX ( chars C0-CF)
c041 w, ( 'A) 0190 w, ( 'E) c049 w, ( 'I)
c04f w, ( 'O) c055 w, ( 'U)
b061 w, ( 'a 01a0) 09fb w, ( 'e ) 01a1 w, ( 'i)
b06f w, ( 'o 01a2) b075 w, ( 'u 01a3) ( ague accents on vowels)
c141 w, ( A') c145 w, ( E') c149 w, ( I')
c14f w, ( O') c155 w, ( U')
09c0 w, ( a') 09fd w, ( e') 018d w, ( i')
b16f w, ( o' 0195) 0add w, ( u') ( grave accents on vowels)
c241 w, ( ^A) c245 w, ( ^E) c249 w, ( ^I)
c24f w, ( ^O) c255 w, ( ^U) ( changed 'b' to 'c'** )
b261 w, ( ^a 0183) b265 w, ( ^e 0188) 018c w, ( ^i)
b26f w, ( ^o 0193) b275 w, ( ^u 0196) ( circumflex accents on vowels)
0bdb w, ( "A) c345 w, ( "E) c349 w, ( "I)
0bdc w, ( "O) 0bdd w, ( "U)
0bfb w, ( "a) b365 w, ( "e 0189) 018b w, ( "i)
0bfc w, ( "o) 0bfd w, ( "u) ( umlauts on vowels)
01a5 w, ( N ) 01a4 w, ( n ) ( tildes on N's)
c359 w, ( "Y ) b379 w, ( "y 0198) ( umlauts on Y's)
ch A ( no ~A ) b661 w, ( ~a)
ch O ( no ~O ) b66f w, ( ~o) ( funny Danish vowels characters fb-ff)
" AEIOU" c8 ,accents
" aeiou" b8 ,accents ( curved circ on vowels chars 100-109)
cr ." LBP printer table is" here target - tc' LBP.printer 2+ - 2/ .
." entries. "
( New & Improved Character set for BJ80/MX80 printers 2July87/dab&pb )
code BJ80.printer nx ) jsr, ;c ( a ROM array)
( bubblejet char table: CG2, 'standard' [not Norway/Denmark] mode)
( Norway/denmark mode would lose Pt, script f, 1/2, 1/4, <<, >> , and would
gain L-dot, l-dot, script-l, and tick-n in return [plus o-slash, O-slash,
o-tilde, O-tilde, A-tilde, a-tilde would no longer be kludged, but cents, Yen,
a-bar, o-bar would have to be kludged])
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
spc w, spc w, spc w, spc w, spc w, spc w, spc w, spc w,
( 32 blanks for 00-1F)
spc w, ch ! ch " " #$%&'()*+,-./" ,chars ( chars 20-2F)
" 0123456789:;<=>?" ,chars ( chars 30-3F)
" @ABCDEFGHIJKLMNO" ,chars ( chars 40-4F)
" PQRSTUVWXYZ[\]^_" ,chars ( chars 50-5F)
" `abcdefghijklmno" ,chars ( chars 60-6F)
" pqrstuvwxyz{|}~" ,chars ( chars 70-7E)
XXX ( no triangle) 80 w, ( Cedilla) F1 w, ( plus-minus)
XXX ( dbl bar) os /O ( O-slash) os /o ( o-slash)
E1 w, ( Beta) 86 w, ( a-dot) 87 w, ( cedilla)
ch L ( no L-dot) ch l ( no l-dot) XXX ( no B-%)
XXX ( no B-s) ch n ( was 'n) ch N ( was 'N)
XXX ( no script-l) 8F w, ( A-dot) ( chars 7F-8F)
F8 w, ( degrees) 91 w, ( ae) 92 w, ( AE)
XXX ( perm space) XXX ( no para) 15 w, ( section)
XXX ( no 1/8) XXX ( no 3/8) XXX ( no 5/8)
XXX ( no 3/4) XXX ( no 7/8) 9B w, ( cents)
9C w, ( lbs) 9D w, ( Yen) 9E w, ( Pt)
9f w, ( script-f) ( chars 90-9F)
XXX ( no TM) XXX ( no circ-r) XXX ( no circ-c)
XXX ( dagger) FD w, ( super 2) XXX ( no super 3)
A6 w, ( a-dash) A7 w, ( o-dash) A8 w, ( leading ?)
F6 w, ( divide) XXX ( os space) AB w, ( 1/2)
AC w, ( 1/4) AD w, ( leading-!) AE w, ( <<)
AF w, ( >>) ( chars A0-AF)
XXX ( lc ague) XXX ( lc grave) ch ^ ( lc circumflex)
XXX ( umlaut) ch _ ( was dbl-ul) XXX ( was bare dots)
ch ~ ( lc tilde) ch - ( strikeout) XXX ( lc curved circ.)
XXX XXX XXX ( RFU)
XXX XXX XXX ( RFU)
XXX ( chars B0-BF)
XXX ( uc ague) XXX ( uc grave) ch ^ ( uc circumflex)
XXX ( umlaut) ch _ ( was dbl-ul) XXX ( was bare dots)
ch ~ ( uc tilde) ch - ( strikeout) XXX ( uc curved circ.)
XXX XXX XXX ( RFU)
XXX XXX XXX ( RFU)
XXX ( chars C0-CF)
ch A ( A w/o ague) 90 w, ( E ague)
" IOU" ,chars ( IOU w/o ague)
A0 w, ( a ague) 82 w, ( e ague)
A1 w, ( i ague) A2 w, ( o ague) A3 w, ( u ague)
" AEIOU" ,chars ( AEIOU w/o grave)
85 w, ( a grave) 8A w, ( e grave) 8D w, ( i grave)
95 w, ( o grave) 97 w, ( u grave)
" AEIOU" ,chars ( AEIOU w/o circumflex )
83 w, ( a-hat) 88 w, ( e-hat) 8C w, ( i-hat)
93 w, ( o-hat) 96 w, ( u-hat)
( Vowels with umlauts)
8E w, ( A-dots) ch E ( E-no dots) ch I ( I-no dots)
99 w, ( O-dots) 9A w, ( U-dots)
84 w, ( a-dots) 89 w, ( e-dots) 8B w, ( i-dots)
94 w, ( o-dots) 81 w, ( u-dots)
A5 w, ( N-tilde) A4 w, ( n-tilde)
ch Y ( no Y-dots) 98 w, ( y-dots)
ch A ( no A-tilde) ch a ( a-tilde)
ch O ( no O-tilde) ch o ( o-tilde) ( funny Danish vowels)
" AEIOU" ,chars ( AEIOU w/o curved circumflex)
83 w, ( a-hat) 88 w, ( e-hat) 8C w, ( i-hat)
93 w, ( o-hat) 96 w, ( u-hat)
cr ." BJ80 printer table is" here target - tc' BJ80.printer 2+ - 2/ .
." entries. "
( Exceptions if Second Set is selected)
code bjsecond.dw nx ) jsr, ;c
9d w, 83 c, ( O-slash) 9b w, 84 c, ( o-slash)
9e w, 88 c, ( L-dot) 9f w, 89 c, ( l-dot)
20 w, 9e c, ( no Pt) 20 w, ae c, ( no << )
ac w, 8c c, ( 'n ) ab w, 8e c, ( script-l)
20 w, 9b c, ( no cents) os =Y 9d c, ( no Yen)
20 w, 9f c, ( no florin) ae w, a5 c, ( super 3)
20 w, a6 c, ( no a-bar) 20 w, a7 c, ( no o-bar)
20 w, ab c, ( no 1/2) 20 w, ac c, ( no 1/4)
aa w, fc c, ( A-tilde) a9 w, fd c, ( a-tilde)
a7 w, fe c, ( O-tilde) a6 w, ff c, ( o-tilde)
-1 w, ( end of bj second set exceptions)
( Build buffer -> Printcode translation table )
code vanilla.unbuild nx ) jsr, ;c ( a ROM array)
0D0 ( initial index value)
" AEIOUaeiou" 0c0 ,unbuild ( ague accents)
" AEIOUaeiou" 0c1 ,unbuild ( grave accents)
" AEIOUaeiou" 0c2 ,unbuild ( circumflex accents)
" AEIOUaeiou" 0c3 ,unbuild ( umlaut accents)
" Nn" 0c6 ,unbuild ( Ennye )
" Yy" 0c3 ,unbuild ( Y-umlaut)
" AaOo" 0c6 ,unbuild ( Norway/Denmark O-tilde, A-tilde)
" AEIOUaeiou" 0c8 ,unbuild ( curved circumflex accents)
0 , ( mark end of table)
cr ." Vanilla unbuild table is " . ." entries."
( Print command & associated stuff -- 18feb87/dab )
code unbuild ( -- known? valid? )
( take an lbuff character and decompose it for printing)
( 'known?' is true if char is a know combination)
( 'valid?' is false if we have run past printlimit)
i' printnext a0 move,
0 #n d0 moveq,
a0 3 )d d0 .b move, ( get overstrike char)
ne if, ( overstruck)
8 #n d0 .w lsl, a0 ) d0 .b move, ( d0: key for unbuildtable)
i' unbuildtable a1 move, ( a1: unbuild assoc. table)
begin, a1 )+ d0 .w cmp,
eq if, ( matched ) a1 ) d0 .w move, 0 bra, then,
a1 )+ .w tst,
eq until, ( keep scanning to end of table)
( never matched, so something strange is happening )
d0 i' prchar move, sp -) clr, ( not known)
else,
a0 ) d0 .b move, ( it is a simple character)
0 :l
d0 i' prchar move, ( save it away)
-1 #n sp -) move, ( character is recognized)
then,
spc #n d0 .w cmp, ls i' prwhite? 3 + set, ( is char white?)
( now check out the character flags )
0 #n d0 moveq, a0 1 )d d0 .b move, ( current flags)
smallbit #n d0 btst, ne i' prsmall? 3 + set,
invbit #n d0 btst, ne i' printed? 3 + set,
i' proldflags 2+ d1 .w move, d0 d1 eor,
d0 i' proldflags 2+ .w move,
ulinebit #n d1 btst, ne i' pr\uline/ 3 + set,
boldbit #n d1 btst, ne i' pr\bold/ 3 + set,
dlinebit #n d1 btst, ne i' pr\dline/ 3 + set, ( for laughs)
i' backwards tst,
ne if, i' printlimit a0 cmp,
( high or same) nc d0 set, 4 #n a0 subq,
else, i' printlimit a0 cmp,
ls d0 set, 4 #n a0 addq,
then, a0 i' printnext move,
d0 .w ext, d0 .l ext, d0 sp -) move, ( valid flag)
next;
( Print driver -- basic character shuffling code )
: printerror ( -- \ notify user of a bogus setup, etc. )
syserror error abort ;
: put" ( addr # -- \ send a canned string to the printer )
?dup if 0 do dup c@ <printc> 1+ loop then drop ;
: motion ( halfchars -- \ keep track of carriage motion )
backwards if negate then prcol +
gutter negate max rightstop gutter - min prcol to ;
: newline ( -- \ put the printer at the start of the next line )
boustrophedon not if gutter negate prcol to then
2 prline +to
oddhalfspace off
bolded if -bold" put" bolded off then
underlined if -underline" put" underlined off then
endline" put"
proldflags off ;
: newhalfline ( -- \ move paper up 1/2 a line)
halfline" put" 1 prline +to ;
: oldhalfline ( -- \ move paper back by 1/2 line )
oldhalfline" put" -1 prline +to ;
: backspace ( -- \ puts printer in position to overstrike prev. char)
braindamaged if backwards if 20 else 08 then <printc> else
backspace" put" then -2 motion ;
: halfspace ( -- \ move the print carriage half of a character )
braindamaged backwards and if backspace then
oddhalfspace if oddhalfspace" else evenhalfspace" then put"
oddhalfspace not oddhalfspace to 1 motion ;
: printc ( char -- \ maybe doublestrike the character to the printer )
knowsbold? not bolded and
if dup <printc> backspace then <printc>
2 motion ;
: paperlength #above c@ #long w@ + #below c@ +
papershort - ;
( Vertical paper motion )
: toline ( pos -- \ feed paper to halfline pos )
prline - ( half lines to go )
dup 0 > if ( not too far already)
dup 1 and if newhalfline then
2/ dup 0 > if 0 do newline loop else drop then
else drop then ;
: formfeed ( -- \ feed out the current page )
knowstof? if
#nextwr @ gap > stopprint or
if endprint" ( last FF of this print) else
topofform" ( a regular formfeed) then put"
else paperlength toline startline" put" then
gutter negate prcol to prline off backwards off ;
: page#string ( -- addr # \ format the #pgl page number)
#pgl @ #ipage w@ 16bitsignex + ( the displayed page # )
<# rightfrill" "hold
dup abs #s swap 0< if ascii - hold then
leftfrill" "hold #> ;
: printfooter ( -- \ print the page footer line )
local #digits local radix base radix to decimal
leftfoot" ?dup if 0 tocol print" else drop then ( left hand footer)
page#string ( decorated page number string )
50 over - tocol ( center page# over column 40)
print" ( write the page #)
rightfoot" ?dup if a0 over 2* - tocol print" ( right hand footer legend)
else drop then radix base to ;
: csf? ( -- f \ tell if a cut-sheet feeder is present, [but lie like a rug])
5 printerinfo ;
: newpage? ( -- \ prepare a new page if necessary )
prline 0= if
#above c@
printercode 0= ( the K. Nakamura Memorial 'bug' 262 printer hack... )
if dup 7 < ( .5" margin? )
csf? 0= ( no CSF?) and if drop 0 then then
dup paperpos > if paperpos - else drop 0 then toline
#above c@ prline to then
;
: pagebreak ( -- \ output a page break )
local temp
pageprint if stopprint on then
#pgl @ #ipage w@ 16bitsignex + ( displayed page number )
#iprint w@ 16bitsignex < not ( needs to print?)
prline paperlength footpos - > not and ( & someplace to put it? )
if newpage? paperlength footpos - toline printfooter then
formfeed ( eject the piece of paper )
lbuff [ 2 lbufwide * ] literal + c@ ds =
if ( this is a doc break )
#wr @ nextchar gap > stopprint or ( finished printing? )
not if #wr @ temp to
temp nextchar findchar 'docbreak execute temp findchar then
( set up for a new document )
then ;
: showpage ( -- \ display the current page being printed, also wrap thru )
#wr @ displaybos bos findchar ( show page we completed )
checkline# rule ; ( make the ruler match the display)
: skippage ( -- \ move over this page break )
#wr @ c@ page? if #wr @ nextchar findchar
( I have lost the will to live!) else
bos nextchar eos = if stopprint on then ( 1 char after implicit?)
then ;
: pagebreak? ( -- f \ is this line some sort of page break?)
lbuff [ 2 lbufwide * ] literal + c@ dup page?
swap softpage mpb inrange or ;
( Character rendering )
: short? ( char -- flag \ is this character lowercase? )
4 shl 11 + ['] romanfont +table @ + c@ 1 and ;
: overstrike ( char -- \ print char w/o moving carriage )
dup 2* printertable + w@ white? if drop else
knowsos? if overstrike" put" print -2 motion
unoverstrike" put"
else print backspace then then ;
: white? ( char -- f \ is this character white looking? )
dup 21 < over [ permspc ] literal = or swap [ overspace ] literal = or ;
: print ( printcode -- \ print a char, printer independently )
( printer won't uline white space )
dup white? underlined and ulinehack? and
if
bolded if -bold" put" then
drop 5f printc
bolded if +bold" put" then
else
2* printertable + dup c@
?dup if ( not a 'simple' char )
dup 1F > if overstrike 1+ c@ printc
else 'weirdprint execute then
else
1+ c@ printc then
then ;
: print" ( addr # -- \ write a string printer independently)
backwards if backwards off printforward" put" then
dup 0 > if over + swap do i c@ print loop else 2drop then ;
: render ( flag -- \ render graphics for most printers)
local flag flag to ( avoid carrying flag on stack a long way)
pr\uline/ if
[ 1 ulinebit shl ] literal proldflags and 0= not underlined to
underlined if +underline" put" else -underline" put" then
then
pr\bold/ if
[ 1 boldbit shl ] literal proldflags and 0= not bolded to
bolded if +bold" put" else -bold" put" then
then
knowsul? not underlined and if 5F overstrike then
prsmall? if halfspace else
flag if ( normal or accented)
prchar print
else ( overstruck)
prchar 8 shr ( overstruck char)
dup C0 CF inrange ( an lbuff accent?)
if ( accented) prchar 0FF and short?
if 10 - ( shift to lowercase accent ) then then
overstrike ( print the overstrike)