**********************************************************************
* EQUATION STACK
*
* ASTK - Stack display replacement which shows symbolics
* in equation writer form.
* AGROB - Related object decompiler
**********************************************************************
**********************************************************************
* UFL DEFINITIONS
**********************************************************************
DEFINE xFNTSTR "FNT"
DEFINE xFNT ROMPTR 101 0
DEFINE Font ROMPTR 101 1
DEFINE Font? ROMPTR 101 2
DEFINE FNT1 ROMPTR 101 3
DEFINE FNT2 ROMPTR 101 4
**********************************************************************
* CACHE DEFINITIONS
**********************************************************************
* Cache size
DEFINE CacheSize TEN
* Twice cache size
DEFINE DoubleSize TWENTY
* Total number of lambda variables
DEFINE TotalSize TWENTYFIVE
ASSEMBLE
=CacheDummy EQU 0 * Equate for zero cache
CACHEPOS EQU 5 * Number of non-cache variables
CACHESIZE EQU 10 * Cache size
CACHESTK EQU 20 * Number of stack levels checked to keep ob in cache
RPL
* Don't forget to check GetCache uses the proper lambda name!
**********************************************************************
* EQUATES
**********************************************************************
ASSEMBLE
* Flag for removing fancy user function features
fFANCYUSER EQU 1
* Flag for removing built-in special identifiers
fFANCYIDS EQU 2
* Flag for removing dotted identifiers
fFANCYDOT EQU 3
SETFLAG fFANCYUSER Enabled by default
SETFLAG fFANCYIDS Enabled by default
SETFLAG fFANCYDOT Enabled by default
* Max number of elements in {} for fancy display in ASTK
MAXLIST EQU 20
* Max number of elements in 1D or 2D array
MAXARRY EQU 10*10
* Font size variable address is within TESTMSG RAM area (44 nibbles)
* 1 - small
* 2 - medium
* 3 - big
* The areas overlap (excluding IRAM@) so we use the bigger start
* address (G_TESTMSG) as the storage place.
=FNT EQU #80092 SX: 008C GX: 0092
* Unsupported entries
=aTEMPENV EQU #04E68
=aSystemFlags EQU #1C645
=STUFF EQU #0675F
=push#c EQU #07230
=push# EQU #07233
=grob! EQU #116B5
=UnScroll EQU #13695
=UNDO_TOP? EQU #14E6D
=HALTTempEnv? EQU #1506B
=STKDECOMP$ EQU #15955
=GETPTREVALC EQU #15C77
=LastRomWord@ EQU #18802
='EvalNoCK: EQU #18F6A
=GPPushALp EQU #307D5
=DoCont/Kill EQU #3875F
=FixStk&Menu EQU #387BE
=SysErrFixUI EQU #3881D
=MakeErrMesg EQU #3889F
=ProcessAlarm EQU #3894E
=DA1Temp? EQU #3931D
=NoRollDA2? EQU #39569
=?PICK EQU #44197
=NULLPAINT EQU #505B2
=ClrnewEditL EQU #53A90
=KeyObLam EQU #5A777
=numargs EQU #5E889
=CKNfcn? EQU #5E9A7
=splitonearg EQU #5EAC2
=pullDROP EQU #5EAF4
=roll2ND EQU #5EB58
=unroll2ND EQU #5EBDB
=scanahead EQU #5F821
=SCANAHEAD EQU #5F926
=rpnsplit EQU #5F996
=push#a EQU #62704
=#_123 EQU #64E6E
=Err#Cont EQU #64EFA
=#CAlarmErr EQU #65080
=ROMPTAB EQU #707D9
=G_ROMPTAB EQU #809A3
* Functions
*=x+ EQU #1AB67
*=x- EQU #1AD09
*=x* EQU #1ADEE
*=x/ EQU #1AF05
=xNEG EQU #1A995
*=x^ EQU #1B02D
=xSQRT EQU #1B374
*=xIFTE EQU #1A3FE * No fancy display implemented
=x= EQU #1A8D8
=xABS EQU #1AA1F
=xCONJ EQU #1AA6E
=xXROOT EQU #1B1CA
=xINV EQU #1B278
=xSQ EQU #1B426
=xEXP EQU #1B905
=xALOG EQU #1BA3D
*=xFACT EQU #1BB02
=xMOD EQU #1BE4D
*=xOBJ> EQU #1CF7B
=xAND EQU #1E783
=xOR EQU #1E809
=xNOT EQU #1E88F
=xXOR EQU #1E8F6
=x== EQU #1E972
=x<> EQU #1EA9D
=x< EQU #1EBBE
=x> EQU #1EC5D
=x<= EQU #1ECFC
=x>= EQU #1ED9B
*=xDER EQU #1EFD2
=xINTG EQU #1F223
=xSUM EQU #1F2C9
*=xWHERE EQU #1F3F3
RPL
**********************************************************************
* Library declarations
**********************************************************************
xROMID 2E4 ( 740 )
EXTERNAL xAGROB
EXTERNAL xASTK
EXTERNAL AGrob
ASSEMBLE
=CfgEqStk
RPL
:: 740 TOSRRP
' ID agrob PuHiddenVar
;
**********************************************************************
* AGROB Command
**********************************************************************
ASSEMBLE
CON(1) 8
RPL
xNAME AGROB
::
CK2&Dispatch
ONE
::
COERCE TRUE ( ob %size flg )
FNT1 FNT2
{ LAM #FNT1 LAM #FNT2 }
BIND
::
( Evaluate from hidden dir if already there )
' ID agrob RclHiddenVar case EVAL
( Fetch parser program )
RESOROMP AGrob
( Test if it is in temporary object area )
CODE
A=DAT1 A
?A<=B A
GOYES +
+ GOVLNG =PushT/FLoop
ENDCODE
( If not then it is safe to evaluate directly )
NOTcase EVAL
( Else store it to hidden directory for evaluation )
' ID agrob DUPUNROT StoHiddenVar RclHiddenVar DROP
EVAL
' ID agrob PuHiddenVar
;
DROP ABND
;
;
**********************************************************************
* ASTK Command
**********************************************************************
ASSEMBLE
CON(1) 8
RPL
xNAME ASTK
::
CK0NOLASTWD
* If ASTK already running change font and clear cache
' LAM #ASTK @ case
::
NOT ' LAM #ASTK STO
CODE
GOSUB GetCache D0 = ->ob1
clrcache LC(2) 2*(CACHESIZE)-1 Number of bindings - 1
A=0 A
- DAT0=A A
D0=D0+ 10
C=C-1 B
GONC -
GOVLNG =GETPTRLOOP
ENDCODE
;
* Cache variables
' CacheDummy DoubleSize NDUPN DROP
* System flags associated with the cache
RCLSYSF
* Store AGrob in hidden dir if we are covered
RESOROMP AGrob
CODE
A=DAT1 A
?A<=B A
GOYES +
+ GOVLNG =PushT/FLoop
ENDCODE
IT :: ' ID agrob DUPUNROT StoHiddenVar RclHiddenVar DROP ;
TRUE FNT1 FNT2
* Bind lambda variables
' NULLLAM DoubleSize NDUPN DROP
{ LAM #SYSF LAM #AGRB LAM #ASTK LAM #FNT1 LAM #FNT2 }
INCOMPDROP TotalSize DOBIND
**
** Main Loop
**
BEGIN
* Regular updates
ClrDA1IsStat AtUserStack SysMenuCheck
* Display stack
DA2aOK?NOTIT
::
KEYINBUFFER? NOT DA2aLess1OK? OR NOTcase SetDA2aBad
TOADISP
DA2aLess1OK? ClrnewEditL case
::
SetDA2aValid NoRollDA2? case ClrNoRollDA2
CODE
GOSBVL =SAVPTR
GOSBVL =D0->Row1
D1=A
LC(5) 10*34
A=A+C A
D0=A
LC(5) (56-8)*34
GOSBVL =MOVEDOWN
GOSBVL =GETPTRLOOP
ENDCODE
;
* Stack display about to be done - check cache
* We remove any ob not contained in the CACHESTK lowest stack levels.
* Then the cache is packed so that cleared slots are last in the cache.
* First we check changes in display mode flags though, if any changes
* are detected we automatically clear the cache.
CODE
GOSUB GetCache D0 = ->ob1
* The system flags are bound right before the cache objects
D0=D0- 10 D0 = ->sysf
A=DAT0 A
AD0EX
B=A A
B=B+CON A,10 Fix B[A] to ->ob1 in cache
D0=D0+ 10
A=DAT0 W A[W] = old flags
D1=(5) =aSystemFlags
C=DAT1 A
D1=C
C=DAT1 W C[W] = new flags
DAT0=C W save new flags
D=C W D[W] = new flags
LCHEX 7F0000403C000 mask for display flags
A=A&C W A[W] = old display flags
C=C&D W C[W] = new display flags
?A=C W
GOYES ckcache The same - check stack
A=B A
D0=A D0 = ->ob1 in cache
GOTO clrcache Clear cache
ckcache C=B A
D0=C D0 = ->ob1
* Clear slots which are not in stack
LC(2) (CACHESIZE)-1 Number of slots to check
-- RSTK=C
A=DAT0 A
?A=0 A
GOYES ++ Empty slot - no need to check it
GOSBVL =D1=DSKTOP
LC(2) (CACHESTK)-1
D=C B Number of stack levels to check
- C=DAT1 A
?A=C A
GOYES ++ Is on stack - keep it
?C=0 A
GOYES + End of stack - don't keep it
D1=D1+ 5
D=D-1 B
GONC -
+ A=0 A Clear cache slot
DAT0=A A
D0=D0+ 10
DAT0=A A
D0=D0- 10
++ D0=D0+ 10 Skip to next cache slot
D0=D0+ 10
C=RSTK
C=C-1 B
GONC -- Check CACHESIZE slots
* Pack the cache
C=B A
D0=C ->ob1 (input)
D1=C ->ob1 (output)
LC(2) (CACHESIZE)-1
D=C B Number of slots to check
-- A=DAT0 A ->ob[i]
D0=D0+ 10
C=DAT0 A ->grob[i]
D0=D0+ 10
?A=0 A
GOYES + If empty then don't output it
DAT1=A A Output the used slot
D1=D1+ 10
DAT1=C A
D1=D1+ 10
+ D=D-1 B
GONC -- Check all slots
AD0EX A[A] = ->cache end
C=0 A
-- CD1EX
?C>=A A
GOYES + Done clearing remaining slots
CD1EX
DAT1=C A
D1=D1+ 10
* DAT1=C A These two instructions could be
* D1=D1+ 10 commented out to save space
GONC -- Keep clearing until end of cache
+ GOVLNG =GETPTRLOOP
* This subroutine saves variables and finds the cache.
* If cache is not found a warmstart is generated
* Else D0 = ->ob1
* Note: cache slot = nulllam ob nulllam grob
GetCache GOSBVL =SAVPTR
D0=(5) =aTEMPENV
A=DAT0 A
D0=A
A=DAT0 A
-- D0=A ->tempenv[i]
D0=D0+ 10
C=DAT0 A C[A] = ->name1[i]
CD0EX
D0=D0+ 5
A=DAT0 12
D0=C
C=A W
LC(N) 2*5+2 First lambda name in the environment
CON(2) 5 the cache is in is LAM #FNT2
NIBASC '#FNT2'
?A=C W
GOYES ++ Found the environment!
D0=D0- 10 D0 = ->tempenv[i]
C=DAT0 A
AD0EX
A=A+C A A[A] = ->tempenv[i++]
?C#0 A
GOYES -- Keep searching until end of tempenvs
GOVLNG =Warmstart End of tempenvs - warmstart
++ P= 16-(CACHEPOS) Skip regular lams
- D0=D0+ 10
P=P+1
GONC -
D0=D0+ 5 Skip to ->ob1 binding
RTN
ENDCODE
ClrNoRollDA2 ClrAbbrevStk
* Lowest display line is 56, modified by no of editlines
FIFTYSIX FOUR LINESOFSTACK #- TEN #* #-
* Stack displaying from stack level 1
ONE
BEGIN
DUP #2+ ?PICK
* Some embedding is done below to avoid skipob calls
ASSEMBLE
CON(5) =DOCODE
REL(5) ->parse
GOSBVL =popflag
GOC +
* Decompile empty stack level to "1:"
A=DAT1 A "DUP" is safe here (flag popped)
D1=D1- 5
D=D-1 A
DAT1=A A
GOVLNG (=#:>$)+5
* Nonempty stack level. Dispatch to regular/fancy decompiler
* based on object type (and other characteristics)
+ GOSBVL =SAVPTR
C=DAT1 A
D0=C
- A=DAT0 A Skip all leading tags
LC(5) =DOTAG #2AFC
?A#C A
GOYES +
D0=D0+ 5 Skip DOTAG
A=0 A
A=DAT0 B
CD0EX
C=C+A A
C=C+A A Skip name
CD0EX
D0=D0+ 2 Skip name length
GONC -
+
* Now test objects with size limits
LC(2) =DOLIST #2A74
?A=C A
GOYES tstlist
LC(3) =DOARRY #29E8
?A=C A
GOYES tstarry
GOTO tstregu
* Disable fancy display for too big arrays
tstarry D0=D0+ 15 ->dimensions
C=DAT0 A
D=C A D[A] = dims
D=D-1 A dims--
GOC tstarrybad 0-dimension array
C=0 A
LC(1) 2-1
?D>C A
GOYES tstarrybad > 2D array
D0=D0+ 5
A=DAT0 A A[A]=dim[1]
D=D-1 A dims--
GOC tstarrynow
D0=D0+ 5
C=DAT0 A C[A]=dim[2]
GOSBVL =MUL#
GOC tstarrybad Way too big array
A=B A A[A]=dim1*dim2
?A=0 A
GOYES tstarrybad One dimension is zero - bad
tstarrynow LC(5) MAXARRY
?A>C A
GOYES tstarrybad
GOTO dcfancy Small enough - use AGrob
tstarrybad GOTO dcregular Too big - use DECOMP$
* Disable fancy display for too long lists
tstlist D0=D0+ 5 ** BUG: REMOVED A=DAT1 A D0=A
B=0 A elements = 0
- A=DAT0 A
LC(5) =SEMI
?A=C A
GOYES +
B=B+1 A elements++
GOSBVL =SKIPOB
GOTO -
+ A=B A elements
GOSBVL =GETPTR
LC(5) MAXLIST
?A>=C A
GOYES dcregular
GOTO dcfancy
* Test regular objects
tstregu LC(3) =DOSYMB #2AB8
?C=A A
GOYES dcfancy
LC(2) =DOEXT #2ADA
?C=A A
GOYES dcfancy
LC(3) =DOIDNT #2E48
?C=A A
GOYES dcfancy
LC(2) =DOLAM #2E6D
?C=A A
GOYES dcfancy
LC(2) =DOROMP #2E92
?A=C A
GOYES dcfancy
LC(3) =DOARRY #29E8
?C=A A
GOYES dcfancy
LC(3) =DOGROB #2B1E
?C=A A
GOYES dcfancy
* Regular decompiler
dcregular GOSBVL =GETPTR
C=DAT1 10 "OVERSWAP"
D1=D1- 5
D=D-1 A
DAT1=C 10
LA(5) =STKDECOMP$
PC=(A)
* Fancy decompiler
- GOSBVL =GETPTR
C=RSTK
D0=C
GOVLNG =Loop
dcfancy GOSUB -
RPL
* We want to parse with AGrob. First check if ob is in cache
* Stack: ( .. #topline #level ob --> #topline #level ob/grob FALSE/TRUE )
CODE
GOSUB GetCache D0 = ->ob1
A=DAT1 A
B=A A B[A] = ->ob
LC(2) (CACHESIZE)-1
-- A=DAT0 A
D0=D0+ 10
?A=0 A
GOYES + Empty slot - don't test it (safety)
?A=B A
GOYES ++ Match! Return grob
+ D0=D0+ 10
C=C-1 B
GONC --
GOVLNG =GPPushFLoop ( --> #topline #level ob FALSE )
++ A=DAT0 A ->grob
DAT1=A A
GOVLNG =GPPushTLoop ( --> #topline #level grob TRUE )
ENDCODE
* If not cached then decompile and add to cache
?SKIP
::
DUP
LAM #ASTK ITE ONE TWO FALSE ( #topline #level ob ob #fnt false )
LAM #AGRB EVAL DROP ( #topline #level ob grob )
CODE
GOSUB GetCache D0 = ->ob1
LC(2) (CACHESIZE)-2
D=C B Number of levels to roll
C=DAT1 A C[A] = ->grob
D1=D1+ 5
A=DAT1 A
B=A A B[A] = ->ob
-- A=DAT0 A A[A] = ->obnext
ABEX A B[A] = ->obnext
DAT0=A A Save ob
D0=D0+ 10
A=DAT0 A A[A] = ->grobnext
ACEX A C[A] = ->grobnext
DAT0=A A Save grob
D0=D0+ 10
D=D-1 B
GONC --
GOVLNG =GETPTRLOOP
ENDCODE
SWAPDROP ( #topline #level grob )
;
* Decompile stack level indicator
* Make index grob
OVER #:>$ LAM #ASTK ITE $>grob $>GROB ( #index G g )
* Modify index grob if g+G is too wide for display
DUP GROBDIMw 3PICK GROBDIMw #+ ( #index G g #w )
XHI #> IT
:: DROPOVER #>$ "; " !append$ LAM #ASTK ITE $>grob $>GROB ;
* Make display grob
DUPGROBDIM DROP 3PICK GROBDIM DROP #MAX XHI MAKEGROB
* Bang index onto display grob
SWAP DUPGROBDIM SWAPDROP UNROT OVER ZEROZERO GROB!
* Bang ob into it
UNROTOVER GROBDIMw DUPUNROT #+ XHI #MAX SWAP#-
ZERO CKGROBFITS
4PICK UNROT GROB!
ASSEMBLE
->parse
RPL
* Stack: ( $ | grob )
* Make sure result is a grob
DTYPECSTR? IT
:: DUPLEN$ TWENTYTWO #> case :: ONE TWENTYONE SUB$ CHR_... >T$ $>GROB ;
$ " " !append$ ONE TWENTYTWO SUB$ $>GROB
;
* Take subgrob if too high and bang into display
DUPGROBDIM 5PICK 3PICK
* Change max if DA1 frozen
DA1Temp? ITE SIXTEEN ZERO #+ #< ITE
::
5ROLL DA1Temp? ITE SIXTEEN ZERO #-
3PICK SWAP#- UNROTSWAP
ZERO 4UNROLL SUBGROB
ABUFF ZERO DA1Temp? ITE SIXTEEN ZERO GROB!
ZEROSWAP ( new max is zero )
;
::
DROP 4ROLL SWAP#- ( new max )
DUP4UNROLL
ABUFF ZERO ROT GROB!
;
* Stacklevel++
#1+
OVER#0= UNTIL ( Repeat until maxline = 0 )
2DROP ( Drop stack level & maxline )
SetDA2aValid
;
* Display editline
DA2bOK?NOTIT DispEditLine
* Display menu
DA3OK?NOTIT ?DispMenu
* Validate display
ClrDAsOK
* Wait and eval key
GetKeyOb ERRSET DoKeyOb
* Special trap to spot CONT exit
ERRTRAP
::
FixStk&Menu
ERROR@ ZERO #=casedrop SysErrFixUI
Err#Cont #=casedrop
::
HALTTempEnv? caseERRJMP
SysErrFixUI RSKIP TRUE ( Exit! )
;
#_123 #=casedrop DoCont/Kill
#CAlarmErr #=case ProcessAlarm
LastRomWord@ ERROR@
SysErrFixUI ERRBEEP MakeErrMesg
TOADISP UnScroll
DISPROW1 DISPROW2
SetDA1Temp
;
FALSE ( no exit )
ClrDA1Bad ( Validate DA1 for ON-key )
UNTIL
* Local exit preparations
' ID agrob PuHiddenVar
* This exit avoids problems with stack save modes when EQSTK
* was entered by typing the command ASTK.
UNDO_TOP? IT ABND ( Abandon possible saved stack )
ABND ( Abandon EQSTK local variables )
TEN GETLAMPAIR ( Fetch first local variable with name )
casedrop CacheStack ( Unlikely possibility of no 1st lam )
UNROT2DROP ( Leave only the name on stack )
EQ: KeyObLam ( Is it KeyOb lam? )
NOTcase CacheStack ( No - just update stack save )
* The stack save mode may have been changed from OFF to ON during EQSTK,
* thus there may not be a stack save below KeyOb and thus an immediate
* UNDO after exit may cause a crash. Thus we explicitly fix the situation.
1GETABND KeyOb! ( This is what the system would do anyway )
CacheStack ( Fix stack save condition - this is enough )
KeyOb@ ' KeyObLam ONE DOBIND ( And bind the KeyOb back in )
; ( And fall through to ROM code )
**********************************************************************
* Fancy symbolic decompiler.
*
* Principle:
*
* Each symbolic can be considered to be of the form
*
* function(expr1,expr2,expr3..exprN)
*
* The decompiler descends recursively into the subexpressions,
* and then combines the resulting grobs as is suitable for
* the top level function.
*
* At the lowest level the expressions have zero arguments, eg
* they are constants or variables. For these the decompiler
* outputs the term in grob form, and returns the 'middle'
* y-coordinate as a system binary.
* At higher levels the functions then combine the grobs
* as indicated by their dimensions, their middle lines and of
* course by the function itself.
*
* For example + simply puts the grobs side by side (with a "+"
* grob in between) so that the middle lines coinside. From
* simple geometric considerations the new middle coordinate
* is simply the greater of the two middle coordinates, and
* the y-coordinates for the grobs are then simply obtained
* as
* max(middle1, middle2) - middle<i>
* and x coordinates of course simply come from the grob x
* dimensions.
*
* Notes:
* For speed all the subroutines are embedded in a single
* object so that slow ROMPTR calls can be avoided.
* This implies that all calls to both RPL and assembly must
* be done in assembly.
**********************************************************************
NULLNAME AGrob
ASSEMBLE
sSTKDC EQU 12 * Used by wakeup code - safe to be used here
CON(5) =DOCODE Embedd everything into a single
REL(5) ->AGrobEnd code object
* Set font size variable in fixed location to avoid recursive
* local variable creation. This of course requires the font
* size to be fixed back explicitly when recursive calls are finished.
ST=0 sSTKDC Assume no stack decompile
GOSBVL =popflag
GOC +
ST=1 sSTKDC Set stack decompile
+ GOSBVL =POP#
GOSBVL =SAVPTR
D0=(5) (=IRAM@)-4
C=DAT0 A
D0=C
D0=(4) FNT
DAT0=A A
GOSBVL =GETPTR
**********************************************************************
* Recursion entry point with given font size
**********************************************************************
FontOb
* Explode symbolic on stack. (Internal version is very slow)
ST=0 10 No GC yet
InnerRetry GOSBVL =PopASavptr
R1=A A R1[A] = ->ob (In case GC is forced)
D0=A
B=0 A complevel = 0
C=0 A
RSTK=C elements = 0
InnerLoop C=DAT0 A
CD0EX
A=DAT0 A @element type
D0=C
LC(5) =PRLG
?A=C A
GOYES InnerOb element is embedded object
A=DAT0 A
D0=D0+ 5
LC(5) =SEMI
?A#C A
GOYES InnerPsh Push address if not SEMI
B=B-1 A complevel--
GONC InnerNxt
InnerOb A=DAT0 A
LC(5) =DOSYMB
?A=C A
GOYES InnerSymb
CD0EX
R0=C A ->element
D0=C
GOSBVL =SKIPOB
A=R0 A ->element
GONC InnerPsh
InnerSymb D0=D0+ 5
B=B+1 A complevel++
GONC InnerLoop
InnerPsh D=D-1 A mem--
GOC InnerGC
D1=D1- 5
DAT1=A A
C=RSTK
C=C+1 A elements++
RSTK=C
InnerNxt ?B#0 A
GOYES InnerLoop
C=RSTK
R0=C A R0[A] = elements
AD1EX
C=D A
RSTK=C
GOSBVL =GETPTR
D1=A
C=RSTK
D=C A
GOSBVL =SAVPTR
GOSBVL =PUSH#
* Explode done, start decompiling
GOTO Font0
InnerGC A=R1 A ->object
GOSBVL =GPPushA
GOSBVL =SAVPTR
GOSBVL =DOGARBAGE Errors if ST10 is set (does GETPTR)
GOTO InnerRetry
**********************************************************************
* The embedded subroutines
**********************************************************************
**********************************************************************
* Dispatch on function given priority table.
* The dispatcher enters the table at some point based on the
* priority of the last function, if the next function is found
* later in the table then dispatch occurs normally, if it is
* before in the table then parenthesis are added after the dispatchee
* finishes.
*
* Note: The table is based on mathematical priority, but is adjusted
* for functions which have special fancy output that makes
* priority obvious.
*
* Note: FCNAPPLY is last in the table, although fancy user function
* output might not support the highest priority. This is
* unavoidable with the current algorithm.
**********************************************************************
Dispatch R0=C.F A offset into function table
A=DAT1 A See if constant term
LC(5) =ONE
?A#C A
GOYES +
D1=D1+ 5 Yes - drop ONE and decompile term
D=D+1 A
GOLONG addobj.1 Use given priority
+ GOSUB PassDsp
PORG CON(5) 0
REL(5) addarg Default dispatchee
PRI0
* CON(5) =xIFTE
* REL(5) addifte
PRI1 CON(5) =xWHERE
REL(5) addwhere
PRI2 CON(5) =xOR
REL(5) addor
PRI3 CON(5) =xAND
REL(5) addand
CON(5) =xXOR
REL(5) addxor
CON(5) =xNOT
REL(5) addnot
PRI4 CON(5) =x=
REL(5) add=
CON(5) =x==
REL(5) add==
CON(5) =x<>
REL(5) add<>
CON(5) =x<
REL(5) add<
CON(5) =x>
REL(5) add>
CON(5) =x<=
REL(5) add<=
CON(5) =x>=
REL(5) add>=
PRI5 CON(5) =x+
REL(5) add+
CON(5) =x-
REL(5) add-
PRI6 CON(5) =xNEG
REL(5) addneg
CON(5) =x*
REL(5) add*
CON(5) =x/
REL(5) add/
CON(5) =xMOD
REL(5) addmod
PRI7 CON(5) =x^
REL(5) add^
CON(5) =xINV
REL(5) addinv
CON(5) =xSQ
REL(5) addsq
CON(5) =xEXP
REL(5) addexp
CON(5) =xALOG
REL(5) addalog
CON(5) =xCONJ
REL(5) addconj
CON(5) =xDER
REL(5) addderiv
PRI8 CON(5) =xSQRT
REL(5) addsqrt
CON(5) =xABS
REL(5) addabs
CON(5) =xINTG
REL(5) addintg
CON(5) =xSUM
REL(5) addsum
CON(5) =xFACT
REL(5) addfact
CON(5) =xFCNAPPLY
REL(5) addfcn
CON(5) =xXROOT
REL(5) addxroot
CON(5) 0 End of table mark
PassDsp C=RSTK
A=R0.F A offset
C=C+A A ->start
R0=C.F A
D1=D1+ 5
A=DAT1 A
D1=D1- 5
CD0EX
RSTK=C
* Search >= priority
- C=DAT0 A
D0=D0+ 10
?C=0 A
GOYES +
?A#C A
GOYES -
* Eval >= priority as is
D0=D0- 5
A=DAT0 A
C=RSTK
CD0EX
A=A+C A
PC=(A)
* Search < priority
+ C=R0.F A
D0=C
- D0=D0- 10
C=DAT0 A
?C=0 A
GOYES ++
?A#C A
GOYES -
* Eval < priority, then add ()
D0=D0+ 5
A=DAT0 A
C=RSTK
CD0EX
C=C+A A dispatchee address
R0=C
A=PC
A=A+CON A,10
PC=(A)
CON(5) =DOCOL
CON(5) =DOCODE
REL(5) +
A=R0
PC=(A) dispatch
+ CON(5) =DOCODE
REL(5) +
GOLONG AddPar
+ CON(5) =SEMI
* No match, eval the default
++ D0=D0+ 5
A=DAT0 A
C=RSTK
CD0EX
A=A+C A
PC=(A)
* Priority entry dispatch points
Font8 LC(5) (PRI8)-(PORG)
GOTO Dispatch
Font7 LC(5) (PRI7)-(PORG)
GOTO Dispatch
Font6 LC(5) (PRI6)-(PORG)
GOTO Dispatch
Font5 LC(5) (PRI5)-(PORG)
GOTO Dispatch
Font4 LC(5) (PRI4)-(PORG)
GOTO Dispatch
Font3 LC(5) (PRI3)-(PORG)
GOTO Dispatch
Font2 LC(5) (PRI2)-(PORG)
GOTO Dispatch
Font1 LC(5) (PRI1)-(PORG)
GOTO Dispatch
FontIt+ GOSUB FNT+
GOTO Font0
FontIt- GOSUB FNT-
Font0 LC(5) (PRI0)-(PORG)
GOTO Dispatch
**********************************************************************
* Font size handling
**********************************************************************
* Fetch FNT variable
D0->FNT CD0EX
D0=(5) (=IRAM@)-4
A=DAT0 A
D0=A
D0=(4) FNT
A=DAT0 A
RTNCC
* Decrease font size
FNT-LOOP GOSUB FNT-
GOVLNG =Loop
FNT- GOSUB D0->FNT
A=A-1 A
DAT0=A A
CD0EX
RTNCC
* Increase font size
FNT+LOOP GOSUB FNT+
GOVLNG =Loop
FNT+ GOSUB D0->FNT
A=A+1 A
DAT0=A A
CD0EX
RTNCC
* Choose grob from return stack and push it
GChoose: GOSBVL =SAVPTR
GOSUB D0->FNT
C=RSTK
D0=C
A=A+A A
GOC +
ASRB.F A
A=A-CON A,2
GOC +
D0=D0+ 5
C=DAT0 A
AD0EX
A=A+C A
AD0EX
A=A-1 A
GOC +
D0=D0+ 5
C=DAT0 A
AD0EX
A=A+C A
AD0EX
+ AD0EX
GOVLNG =GPPushALp
**********************************************************************
* For speed unrolling & rolling is not used, instead the RPL
* return stack is used as a stack.
**********************************************************************
* Push objects
Push2 P=P-1
Push1 P=P-1
C=B A
CD0EX
- A=DAT1 A
DAT0=A A
D0=D0+ 5
D1=D1+ 5
P=P+1
GONC -
CD0EX
B=C A
RTNCC
* Pop objects
Pop2 P=P-1
Pop1 P=P-1
C=B A
CD0EX
- D0=D0- 5
D1=D1- 5
A=DAT0 A
DAT1=A A
P=P+1
GONC -
CD0EX
B=C A
RTNCC
* Pop 1 while saving 2
PopSave A=DAT1 10
D1=D1+ 5
C=B A
CD0EX
RSTK=C
D0=D0- 5
C=DAT0 A
DAT1=C A
DAT0=A 10
D0=D0+ 10
C=RSTK
CD0EX
B=C A
RTNCC
Pop1Loop GOSUB Pop1
GONC +
Pop2Loop GOSUB Pop2
GONC +
Push1Loop GOSUB Push1
GONC +
Push2Loop GOSUB Push2
+ GOVLNG =Loop
**********************************************************************
* Find size of the last argument of the topmost function
* ( expr1 expr2 fcn #n1+n2+1 --> expr1 expr2 #n2 #n1 )
**********************************************************************
Split GOSBVL =SAVPTR
D1=D1+ 10
C=0 A
LC(1) 1
R0=C A Stack level
R1=C A 1 expression to extract
GOSBVL =scanahead
GOSBVL =D1=DSKTOP
GOSBVL =POP#
C=R0 A
A=A-C A
R0=A A
C=C-1 A
R1=C A
GOSBVL =PUSH2#
A=DAT1 A
D1=D1+ 5
D=D+1 A
C=DAT1 A
D1=D1+ 5
D=D+1 A
DAT1=C A
D1=D1+ 5
DAT1=A A
D1=D1- 5
RTNCC
*********************************
* SWAPDROP#1-
*********************************
Pull GOSBVL =POP#
A=A-1 A
R0=A
GOSBVL =PopASavptr
GOVLNG =PUSH#
*********************************
* ( Meta grb #mid --> grb #mid )
* iff STKDC and grb wide
*********************************
StkAbort? ?ST=0 sSTKDC
RTNYES
D1=D1+ 5
C=DAT1 A C[A] = ->grob
D1=D1- 5
CD0EX
D0=D0+ 15
A=DAT0 A grob width
D0=C
LC(5) 131
?A<C A
RTNYES
StkAbort C=RSTK
A=DAT1 10
D1=D1+ 10
R0=A W
GOSBVL =POP#
C=A A
D=D+C A
AD1EX
A=A+C A
C=C+C A
C=C+C A
A=A+C A
D1=A
A=R0 W
D1=D1- 10
DAT1=A 10
GOVLNG (=SEMI)+5
RPL
**********************************************************************
* Function dispatchees
**********************************************************************
LABEL add+
::
plDRPpZparg ( B A )
CODE
GOTO Font5
ENDCODE
CODE
GOSUB StkAbort?
GOSUB Push2
GOTO Font5
ENDCODE
CODE
GOSUB Pop2
GOSUBL Swap2
GOSUB GChoose:
NIBHEX E1B2071000400004000020702000
NIBHEX E1B20B100060000600004040F1404000
NIBHEX E1B20B100060000600004040F1404000
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL add-
::
plDRPpZparg ( B A )
CODE
GOTO Font5
ENDCODE
CODE
GOSUB StkAbort?
GOSUB Push2
GOTO Font6
ENDCODE
CODE
GOSUB Pop2
GOSUBL Swap2
GOSUB GChoose:
NIBHEX E1B203100020000400007000
NIBHEX E1B20310002000060000F100
NIBHEX E1B20310002000060000F100
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addneg
::
CODE
GOSUB Pull
GOTO Font6
ENDCODE
CODE
GOSUB GChoose:
NIBHEX E1B203100020000400007000
NIBHEX E1B20310002000060000F100
NIBHEX E1B20310002000060000F100
ENDCODE
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL add*
::
plDRPpZparg ( B A )
CODE
GOTO Font6 ( B lg # )
ENDCODE
CODE
GOSUB StkAbort?
GOSUB Push2
CD1EX
RSTK=C Save D1
D1=C
- D1=D1+ 5 <--+
A=DAT1 A | Skip possible * functions
LC(5) =x* |
?A=C A |
GOYES - ---+
D1=A
A=DAT1 A Type of non *
LC(5) =DOEXT
?A=C A
GOYES + Save test in CRY
+ C=RSTK
D1=C Restore D1
GOVLNG =PushT/FLoop Push flag
ENDCODE
CODE
GOSUB Push1 Save the flag in return stack
GOTO Font6 And parse right hand arg
ENDCODE
CODE
GOSUB Pop1 Pop the flag to data stack
GOSUB Pop2 ( rg # flg lg # )
GOSUBL Rot ( rg # lg # flg )
GOSBVL =popflag And pop it from there
GONC + If not unit then exit
GOSUBL AddPar!
+ GOSUBL Swap2 ( lg # rg # )
GOVLNG =Loop
ENDCODE
GROB E 20000200001000
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL add/
::
CODE
part1font0 GOSUB Split
GOSUB Push1
GOTO Font0
ENDCODE
CODE
GOSUB PopSave
GOTO Font0
ENDCODE
CODE
GOSUB Pop2
GOLONG AddDiv
ENDCODE
;
**********************************************************************
LABEL add^
::
CODE
GOSUB Split
GOSUB Push1
GOTO FontIt-
ENDCODE
CODE
GOSUB FNT+
GOSUB PopSave
GOTO Font8
ENDCODE
CODE
GOSUB Pop2
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addinv
::
CODE
pullfont8 GOSUB Pull
GOTO Font8
ENDCODE
"-1"
CODE
GOSUB FNT-
GOLONG ObMisc
ENDCODE
CODE
GOSUB FNT+
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addsq
::
CODE
GOTO pullfont8
ENDCODE
"2"
CODE
GOSUB FNT-
GOLONG ObMisc
ENDCODE
CODE
GOSUB FNT+
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addconj
::
CODE
GOTO pullfont8
ENDCODE
GROB 16 6000040000502070205000
THREE
CODE
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addexp
::
CODE
GOSUB Pull
GOTO FontIt-
ENDCODE
GROB 1A 80000600000000E011F110E000
FOUR
CODE
GOSUBL Swap2
GOSUB FNT+
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addalog
::
CODE
GOSUB Pull
GOTO FontIt-
ENDCODE
"10"
CODE
GOSUB FNT+
GOLONG ObMisc
ENDCODE
CODE
GOSUBL Swap2
GOLONG AddExp
ENDCODE
;
**********************************************************************
LABEL addsqrt
::
CODE
pullfont0 GOSUB Pull
GOTO Font0
ENDCODE
CODE
GOLONG AddSqrt
ENDCODE
;
**********************************************************************
LABEL addmod
::
CODE
part1font6 GOSUB Split
GOSUB Push1
GOTO Font6
ENDCODE
CODE
part2font6 GOSUB PopSave
GOTO Font6
ENDCODE
" MOD "
CODE
Pop2RotFont$ GOSUB Pop2
GOSUBL Rot
GOLONG $>font
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL add=
::
"="
CODE
equgeneral A=PC Change stream into following codeob
LC(5) (+)-(*)
A=A+C A
D0=A
GOSUB Push1
GOVLNG =Loop
+
ENDCODE
plDRPpZparg ( B A )
CODE
GOLONG Font4
ENDCODE
CODE
GOSUB Pop1 ( B lg # $ )
GOVLNG =Loop
ENDCODE
4UNROLL ROT#1+UNROT ( B&$ lg # )
CODE
GOSUB StkAbort?
GOVLNG =Loop
ENDCODE
ROT #1-UNROT 4ROLL ( B lg # $ )
CODE
GOSUB Push1 Save $
GOSUB Push2 Save lg #
GOLONG Font4 ( rg # )
ENDCODE
CODE
GOSUB Pop2 ( rg # lg # )
GOSUB Swap2 ( lg # rg # )
GOSUB Pop1 ( lg # rg # $ )
GOLONG $>font ( lf # rg # G )
ENDCODE
CODE
GOTO Middle
ENDCODE
;
*********************************
LABEL add==
::
"=="
CODE
GOTO equgeneral
ENDCODE
(;)
*********************************
LABEL add<>
::
"\8B"
CODE
GOTO equgeneral
ENDCODE
(;)
*********************************
LABEL add<
::
"<"
CODE
GOTO equgeneral
ENDCODE
(;)
*********************************
LABEL add>
::
">"
CODE
GOTO equgeneral
ENDCODE
(;)
*********************************
LABEL add<=
::
"\89"
CODE
GOTO equgeneral
ENDCODE
(;)
*********************************
LABEL add>=
::
"\8A"
CODE
GOTO equgeneral
ENDCODE
(;)
**********************************************************************
LABEL addfact
::
CODE
GOTO pullfont8
ENDCODE
"!"
CODE
GOLONG $>font
ENDCODE
CODE
GOLONG Append
ENDCODE
;
**********************************************************************
LABEL addnot
::
CODE
GOSUB Pull
GOLONG Font4
ENDCODE
GROB E 2000070000F080
CODE
GOTO Insert
ENDCODE
;
**********************************************************************
LABEL addand
::
CODE
part1font3 GOSUBL Split
GOSUBL Push1
GOLONG Font3
ENDCODE
CODE
part2font3 GOSUBL PopSave
GOLONG Font3
ENDCODE
GROB 16 6000080000804141222200
CODE
mergemiddle GOSUBL Pop2
GOSUBL Rot
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addxor
::
CODE
GOTO part1font3
ENDCODE
CODE
GOTO part2font3
ENDCODE
GROB 16 60000800002222414180E3
CODE
GOTO mergemiddle
ENDCODE
;
**********************************************************************
LABEL addor
::
CODE
GOSUBL Split
GOSUBL Push1
GOLONG Font2
ENDCODE
CODE
GOSUBL PopSave
GOLONG Font2
ENDCODE
GROB 16 6000080000222241418000
CODE
GOTO mergemiddle
ENDCODE
;
**********************************************************************
LABEL addfcn
::
SWAPDROP #3-
CODE
GOSUB Unrot
A=PC Change stream into common code
LC(5) (addargsub)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
(;)
**********************************************************************
LABEL addarg
::
#1-SWAP CKNfcn? ITE
:: SWAP#1- UNROTSWAP ;
numargs
* arg1 arg2 .. argN m name n
LABEL addargsub
* Try romptr -> id conversion for name
OVER TYPEROMP? IT
:: SWAP palrompdcmp DROP $>ID SWAP ;
* Try special .n and .nm forms and special function names
ASSEMBLE
IF fFANCYUSER
RPL
* Check special cases
CODE
GOSBVL =SAVPTR
GOSBVL =POP#
ASRC
P= 4
A=0 P
P= 0
?A=0 A
GOYES +
A=0 S ~inf
+ A=DAT1 A
D0=A
A=DAT0 A
LC(5) =DOIDNT
?A=C A
GOYES +
- GOVLNG =GETPTRLOOP
+ D0=D0+ 5
A=0 A
A=DAT0 B
B=A A
A=0 P
?A#0 B
GOYES -
D0=D0+ 2
* Now: A[S] = args (0 if more than 15)
* B[A] = chars in idnt (0<x<16)
* D0 = ->name
* Try .n and .nm endings
CD0EX
D0=C
C=C+B A
C=C+B A
D1=C ->name end
D1=D1- 4
A=DAT1 A
C=A A
LCSTR '.n'
?A#C A
GOYES +
A=PC
LC(5) (fun.n)-(*)
GOTO fungo
+ D1=D1- 2
A=DAT1 6
C=A W
LCSTR '.nm'
?A#C W
GOYES fundispatch
C=C-1 S Match - but must have >=2 args
GOC +
?C=0 S
GOYES fundispatch
+ A=PC
LC(5) (fun.nm)-(*)
GOTO fungo
* Now try special names
fundispatch GOSUB +
SPECFUN MACRO
CON(1) $1 Argument count
CON(1) $2 Name length in characters
NIBASC '$3' Name
REL(5) add$3 Dispatchee offset
SPECFUN ENDM
SPECFUN 2,2,If
SPECFUN 0,3,Top
SPECFUN 2,2,So
SPECFUN 2,3,Equ
SPECFUN 2,3,Mul
SPECFUN 2,2,PM
SPECFUN 2,2,MP
SPECFUN 1,2,pm
SPECFUN 1,2,mp
SPECFUN 2,5,Cross
SPECFUN 1,4,Grad
SPECFUN 1,4,Curl
SPECFUN 1,3,Div
SPECFUN 2,3,Der
SPECFUN 2,3,DER
SPECFUN 2+8,3,der
SPECFUN 1,3,Lap
SPECFUN 1,4,LapT
SPECFUN 1,4,FouT
SPECFUN 1,5,ILapT
SPECFUN 1,5,IFouT
SPECFUN 1,6,Vector
SPECFUN 0,2,Lt
SPECFUN 0,2,Rt
SPECFUN 1,3,Par
SPECFUN 1,2,fp
SPECFUN 1,2,fm
CON(2) 0 End of table
- GOVLNG =GETPTRLOOP
+ C=RSTK
D1=C
funloop C=DAT1 B
?C=0 B
GOYES -
D1=D1+ 2
CSRC
?C#B P If not same length then continue
GOYES funcont
?C=0 S If inf args allowed then compare
GOYES funtest
?C=A S If same args then compare
GOYES funtest
C=C+C S If absolute args then cont
GONC funcont
?A=0 S If lots of args then compare
GOYES funtest (must be more than required then)
CSRB.F S If more args than required then comp
?A>=C S
GOYES funtest
funcont P=C 0 Else skip to next slot
CD1EX
C+P+1
C+P+1
CD1EX
P= 0
D1=D1+ 3
GONC funloop
funtest C=C+C A
P=C 0
P=P-1
A=DAT0 WP
C=DAT1 WP
?A=C WP
GOYES funmatch
C=B A
GONC funcont
funmatch CD1EX
C+P+1
D1=C
P= 0
A=DAT1 A
fungo A=A+C A
GOSBVL =GETPTR
D0=A Change stream
* D0=D0+ 5 Skip DOCOL !!!!
GOVLNG =Loop
ENDCODE
ASSEMBLE
ENDIF * fFANCYUSER
RPL
* Regular name, put arguments in parenthesis
CODE
GOSUB Swap
GOLONG addobj
ENDCODE
* Special entry point for adding arguments for a grob
* ( Meta #args grob #mid )
CODE
addfunargs A=PC
A=A+CON A,16 [6]
D0=A [3]
GOVLNG =Loop [7]
ENDCODE
* Zero arguments
ROT DUP#0=csedrp ROTDROP ( --> grob #mid )
* One argument
DUP#1= casedrop
::
CODE
push2font0 GOSUBL Push2
GOLONG Font0
ENDCODE
CODE
mergefcn GOSUBL AddPar!
GOSUBL Pop2
GOTO InsertG
ENDCODE
;
* More than one argument
CODE
GOSUB Unrot
GOLONG Push2Loop
ENDCODE
DUP
CODE
GOLONG Push1Loop
ENDCODE
ONE_DO (DO) pshzerpsharg LOOP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG Pop1Loop
ENDCODE
ONE_DO (DO)
CODE
GOTO push2font0
ENDCODE
CODE
GOLONG Pop2Loop
ENDCODE
2SWAP
","
CODE
GOLONG $>font
ENDCODE
CODE
GOTO Middle
ENDCODE
LOOP
CODE
GOTO mergefcn
ENDCODE
;
ASSEMBLE
**********************************************************************
* STACK HANDLING SUBROUTINES
**********************************************************************
Swap A=DAT1 A ( 1 2 --> 2 1 )
D1=D1+ 5
C=DAT1 A
DAT1=A A
D1=D1- 5
DAT1=C A
RTN
Swap2 A=DAT1 10 ( 1 2 3 4 --> 3 4 1 2 )
D1=D1+ 10
C=DAT1 10
DAT1=A 10
D1=D1- 10
DAT1=C 10
RTN
Rot A=DAT1 10 ( 1 2 3 --> 2 3 1 )
D1=D1+ 10
C=DAT1 A
D1=D1- 5
DAT1=A 10
D1=D1- 5
DAT1=C A
RTN
Unrot A=DAT1 A ( 1 2 3 --> 3 1 2 )
D1=D1+ 5
C=DAT1 10
D1=D1+ 5
DAT1=A A
D1=D1- 10
DAT1=C 10
RTN
**********************************************************************
* GROB MERGING SUBROUTINES
**********************************************************************
**********************************************************************
* Append 2 arguments with given grob in between
* Stack: g1 m1 g2 m2 g3 --> G M
**********************************************************************
Middle GOSUB Middle!
GOVLNG =Loop
Middle! GOSBVL =SAVPTR
D1=D1+ 5
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A h2
B=A A h2
D1=D1+ 10
C=DAT1 A
D0=C
D0=D0+ 5
C=DAT0 A h1
D=C A h1
?C>=A A
GOYES x8maxh
ACEX A
x8maxh RSTK=C maxh
* RSTK maxh
* B[A] h2
* D[A] h1
D1=D1+ 5
C=DAT1 A g1
D0=C
D0=D0+ 10
C=DAT0 A y1
C=C-D A y1-h1
D=C A y1-h1
D0=D0+ 5
A=DAT0 A x1
D1=D1- 10
C=DAT1 A g2
D0=C
D0=D0+ 10
C=DAT0 A y2
C=C-B A y2-h2
?D>=C A
GOYES x8maxyh
D=C A MAX(y1-h1,y2-h2)
x8maxyh C=RSTK
RSTK=C
C=C+D A Y
R1=C Y
D0=D0+ 5
C=DAT0 A x2
A=A+C A x1+x2
D1=D1- 10
C=DAT1 A g3
D0=C
D0=D0+ 15
C=DAT0 A x3
A=A+C A x1+x2+x3
R0=A X
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10 G
CD0EX
RSTK=C G maxh
* Put g3
GOSBVL =D1=DSKTOP
A=DAT1 A g3
D1=D1+ 10
D1=D1+ 10
C=DAT1 A g1
D0=C
D0=D0+ 15
C=DAT0 A x1
R1=C x1
D0=A g3
D0=D0+ 10
A=DAT0 A y3
D0=D0- 10
ASRB.F A y3/2
C=RSTK
D1=C G
C=RSTK maxh
RSTK=C
C=C-A A maxh-y3/2
R0=C maxh-y3/2
CD1EX
RSTK=C
CD1EX
GOSUBL grb!
* Put g2
GOSBVL =D1=DSKTOP
C=DAT1 A g3
D0=C
D0=D0+ 15
C=DAT0 A x3
D1=D1+ 5
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A h2
B=A A h2
D1=D1+ 15
A=DAT1 A g1
D0=A
D0=D0+ 15
A=DAT0 A x1
A=A+C A x1+x3
R1=A x1+x3
D1=D1- 10
A=DAT1 A g2
D0=A
C=RSTK
D1=C G
C=RSTK maxh
RSTK=C
C=C-B A maxh-h2
R0=C
CD1EX
RSTK=C
CD1EX
GOSUBL grb!
* Put g1
GOSBVL =D1=DSKTOP
D1=D1+ 15
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A h1
D1=D1+ 5
C=DAT1 A g1
D0=C
C=RSTK G
DAT1=C A OVERWR!
D1=C
C=RSTK maxh
RSTK=C
C=C-A A maxh-h1
R0=C
C=0 A
R1=C
GOSUBL grb!
* Push maxh
GOSBVL =GETPTR
D1=D1+ 10
D1=D1+ 10
D=D+CON A,4
C=RSTK maxh
R0=C
GOSBVL =SAVPTR
GOVLNG =PUSH#
**********************************************************************
* Insert symmetric grob
* Stack: g1 m1 g2 --> g2+g1 M
**********************************************************************
Insert GOSUB Insert!
GOVLNG =Loop
Insert! GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A y
ASRB.F A y/2
R0=A
GOSBVL =PUSH#
GOTO InsertG!
**********************************************************************
* Append symmetric grob
* Stack: g1 m1 g2 --> g1+g2 M
**********************************************************************
Append GOSUB Append!
GOVLNG =Loop
Append! GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A y
ASRB.F A y/2
R0=A
GOSBVL =PUSH#
A=DAT1 10
D1=D1+ 10
C=DAT1 10
DAT1=A 10
D1=D1- 10
DAT1=C 10
GOTO InsertG!
**********************************************************************
* Insert grob in front
* Stack: g1 m1 g2 m2 --> g2+g1 M
**********************************************************************
InsertG GOSUB InsertG!
GOVLNG =Loop
InsertG! GOSBVL =SAVPTR
D1=D1+ 15
A=DAT1 A g1
D0=A
D0=D0+ 15
C=DAT0 A x1
D0=D0- 5
A=DAT0 A
B=A A y1
D1=D1- 10
A=DAT1 A g2
D0=A
D0=D0+ 15
A=DAT0 A x2
A=A+C A
R0=A x1+x2
D0=D0- 5
A=DAT0 A y2
D1=D1+ 5
C=DAT1 A
D0=C
D0=D0+ 5
C=DAT0 A
D=C A h1
D1=D1- 10
C=DAT1 A
D0=C
D0=D0+ 5
C=DAT0 A h2
* Registers:
* A[A] y2 C[A] h2
* B[A] y1 D[A] h1
R1=C h2
R2=A y2
A=A-C A y2-h2
C=B A y1
C=C-D A y1-h1
?C<=A A
GOYES okdu00
ACEX A mindif
okdu00 CR1EX h2
?C<=D A
GOYES okdu01
CDEX A
okdu01 A=R1
A=A+C A mins
A=B-A A y1-mins
C=R2
A=A+C A +y2
R1=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
CD0EX
RSTK=C
* Put g2
GOSBVL =D1=DSKTOP
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A h2
D1=D1+ 10
C=DAT1 A
D0=C
D0=D0+ 5
C=DAT0 A h1
C=C-A A
GONC okhd00
C=0 A
okhd00 A=0 A
R1=A
R0=C
D1=D1- 5
A=DAT1 A g2
D0=A
C=RSTK
RSTK=C
D1=C
GOSUBL grb!
* Put g1
GOSBVL =D1=DSKTOP
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A h2
D1=D1+ 5
C=DAT1 A
D0=C
D0=D0+ 15
C=DAT0 A x2
R1=C
D1=D1+ 5
C=DAT1 A
D0=C
D0=D0+ 5
C=DAT0 A h1
B=A A h2
?C<=B A
GOYES okmh00
B=C A maxh
okmh00 A=A-C A h2-h1
GONC okdh01
A=0 A
okdh01 R0=A
D1=D1+ 5
A=DAT1 A g1
D0=A
C=RSTK
DAT1=C A
D1=C
C=B A
RSTK=C
GOSUBL grb!
GOSBVL =GETPTR
D1=D1+ 15
D=D+CON A,3
C=RSTK
R0=C
GOSBVL =SAVPTR
GOVLNG =PUSH#
**********************************************************************
* Merge grobs in exponent form
* Stack: g1 m1 g2 m2 --> G H
**********************************************************************
AddExp GOSUB AddExp!
GOVLNG =Loop
AddExp! D1=D1+ 5
D=D+1 A
GOSBVL =SAVPTR
A=DAT1 A g2
D0=A
D0=D0+ 10
A=DAT0 A
B=A A y2
D0=D0+ 5
C=DAT0 A x2
D1=D1+ 10
A=DAT1 A g1
D0=A
D0=D0+ 10
A=DAT0 A y1
A=A+B A y1+y2
A=A-1 A
A=A-1 A y1+y2-2
R1=A
D0=D0+ 5
A=DAT0 A
A=A+C A x1+x2
R0=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10 G
* Put g1
GOSBVL =D1=DSKTOP
C=DAT1 A g2
CD0EX
RSTK=C G
D0=D0+ 10
A=DAT0 A y2
A=A-1 A
A=A-1 A y2-2
R0=A
A=0 A
R1=A
D1=D1+ 10
A=DAT1 A g1
D0=A
D1=C G
GOSUBL grb!
* Put g2
GOSBVL =D1=DSKTOP
D1=D1+ 10
A=DAT1 A g1
C=RSTK G
DAT1=C A OVERWR!
D0=A
D0=D0+ 15
A=DAT0 A x1
R1=A
A=0 A
R0=A
D1=D1- 10
A=DAT1 A g2
D0=A
D1=C
GOSUBL grb!
* Push h1+y2-2
GOSBVL =GETPTR
A=DAT1 A
AD0EX
D0=D0+ 10
C=DAT0 A y2
D0=A
RSTK=C
D1=D1+ 5
D=D+1 A
GOSBVL =POP# h1
C=RSTK
A=A+C A
A=A-1 A
A=A-1 A h1+y2-2
R0=A
GOSBVL =SAVPTR
GOVLNG =PUSH#
**********************************************************************
* Merge 2 grobs in division form
* Stack: g1 m1 g2 m2 --> G M
**********************************************************************
AddDiv GOSUB AddDiv!
GOVLNG =Loop
AddDiv! D1=D1+ 5
D=D+1 A
A=DAT1 A
D1=D1+ 5
D=D+1 A
DAT1=A A
GOSBVL =SAVPTR
D0=A
D0=D0+ 15
A=DAT0 A
B=A A x2
D0=D0- 5
C=DAT0 A y2
D1=D1+ 5
A=DAT1 A g1
D0=A
D0=D0+ 10
A=DAT0 A y1
C=C+A A
C=C+1 A
C=C+1 A y1+y2+2
R1=C
D0=D0+ 5
C=DAT0 A x1
?C>=B A
GOYES x3okmx
CBEX A
x3okmx R0=C maxx
RSTK=C maxx
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10 G
C=RSTK
B=C A maxx
RSTK=C
GOSBVL =D1=DSKTOP
A=DAT1 A g2
D1=D1+ 5
C=DAT1 A g1
CD0EX
RSTK=C G maxx
D1=C G
D0=D0+ 10
C=DAT0 A y1
D0=A g2
C=C+1 A
C=C+1 A y1+2
R0=C y'
D0=D0+ 15
A=DAT0 A x2
A=B-A A maxx-x2
ASRB.F A
R1=A x'
D0=D0- 15
GOSUBL grb!
GOSBVL =D1=DSKTOP
D1=D1+ 5
C=RSTK G
A=DAT1 A g1
D1=C G
D0=A g1
D0=D0+ 15
A=DAT0 A x1
D0=D0- 15
C=RSTK maxx
RSTK=C
C=C-A A
CSRB.F A
R1=C x'
C=0 A
R0=C y'
CD1EX
RSTK=C G maxx
CD1EX
GOSUBL grb!
GOSBVL =D1=DSKTOP
D1=D1+ 5
A=DAT1 A g1
C=RSTK
DAT1=C A OVERWR!
D0=A
D1=C
D0=D0+ 10
A=DAT0 A y1
A=A+1 A
R0=A y1+1
A=A-1 A y1
D1=D1+ 10
D1=D1+ 10
C=RSTK maxx
D=C A
ACEX A
GOSBVL =w->W W
GOSBVL =MUL# y1*W
CD1EX
C=C+B A
D1=C
D=D-1 A maxx-1
C=D A X
CSRB.F A
CSRB.F A X/4
A=0 W
A=A-1 W
GOSBVL =STUFF
LC(1) 3
C=C&D P
P=C 0
LCHEX 0137
P=C 3
C=0 B
CPEX 0
A=DAT1 B
A=A!C P
DAT1=A B
GOSBVL =GETPTR
D1=D1+ 5
D=D+1 A
GOSBVL =SAVPTR
GOVLNG =PUSH#
**********************************************************************
* Draw square root around grob
* Stack: g1 m1 --> G M
**********************************************************************
AddSqrt GOSBVL =SAVPTR
D1=D1+ 5
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A y
A=A+CON A,3 y+3
R1=A
D0=D0+ 5
A=DAT0 A x
A=A+CON A,5 x+5
R0=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
GOSBVL =D1=DSKTOP
D1=D1+ 5
C=DAT1 A g
CD0EX
DAT1=C A OVERWR!
D1=C
RSTK=C
C=0 A
LC(1) 2
R0=C y'
LC(1) 4
R1=C x'
GOSUBL grb!
C=RSTK
R0=C G
D1=C
D1=D1+ 10
C=DAT1 A
D=C A y+3
D1=D1+ 5
A=DAT1 A w+5
R2=A
D1=D1+ 5
GOSBVL =w->W W
B=A A
* +++++++
* +
* + *****
* + + *****
* ++ *****
* + *****
D=D-1 A
D=D-1 A
LC(1) 4
sqhlp A=DAT1 B
A=A!C P
DAT1=A B
CD1EX
C=C+B A
CD1EX
D=D-1 A
GONC sqhlp
sqllp CD1EX
C=C-B A
CD1EX
A=DAT1 B
A=A!C P
DAT1=A B
CSRB.F P
?C#0 P
GOYES sqllp
C=R0
D1=C
D1=D1+ 10
D1=D1+ 10 G
LC(1) #C
A=DAT1 B
A=A!C P
DAT1=A B
D1=D1+ 1
C=R2 w+5
C=C-CON A,5 w
D=C A w
CSRB.F A
CSRB.F A X/4
A=0 W
A=A-1 W
GOSBVL =STUFF
LC(1) 3
C=C&D P
P=C 0
LCHEX 0137
P=C 3
C=0 B
CPEX 0
A=DAT1 B
A=A!C P
DAT1=A B
GOSBVL =GETPTR
GOSBVL =POP#
A=A+CON A,2
GOVLNG =push#a
**********************************************************************
* Draw parenthesis or brackets around grob
* Stack: g1 m1 --> G M
**********************************************************************
sPAR EQU 5
AddBra GOSUB AddBra!
GOVLNG =Loop
AddPar GOSUB AddPar!
GOVLNG =Loop
AddBra! ST=0 sPAR
GOTO +
AddPar! ST=1 sPAR
+ GOSBVL =SAVPTR
D1=D1+ 5
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A y
R1=A
D0=D0+ 5
A=DAT0 A x
A=A+CON A,6 x+6
R0=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
GOSBVL =D1=DSKTOP
D1=D1+ 5
C=DAT1 A g
CD0EX
DAT1=C A
D1=C
RSTK=C
C=0 A
R0=C y'
LC(1) 3
R1=C x'
GOSUBL grb!
C=RSTK
R0=C G
D1=C
D1=D1+ 10
A=DAT1 A
R1=A y
D1=D1+ 5
A=DAT1 A w
R2=A
D1=D1+ 5
GOSBVL =w->W W
B=A A
* -+ *****+-
* + ***** +
* + ***** +
* + ***** +
* -+ *****+-
* *****
A=DAT1 B
LC(1) 2
?ST=1 sPAR
GOYES +
LC(1) 3
+ A=A!C P
DAT1=A B
C=R1 y
C=C-CON A,4
D=C A
LC(1) 1
lprlp CD1EX
C=C+B A
CD1EX
A=DAT1 B
A=A!C P
DAT1=A B
D=D-1 A
GONC lprlp
CD1EX
C=C+B A
CD1EX
A=DAT1 B
LC(1) 2
?ST=1 sPAR
GOYES +
LC(1) 3
+ A=A!C P
DAT1=A B
A=R0 G
D1=A
D1=D1+ 10
D1=D1+ 10
C=R1 y
C=C-CON A,4
D=C A
A=R2 w
A=A-CON A,3
LC(1) 3
C=C&A P
ASRB.F A
ASRB.F A
CD1EX
C=C+A A
CD1EX
P=C 0
LCHEX 1248
P=C 3
C=0 B
CPEX 0
A=DAT1 B
A=A!C B
C=C+C B
?ST=1 sPAR
GOYES +
A=A!C B
+ DAT1=A B
rprlp CD1EX
C=C+B A
CD1EX
A=DAT1 B
A=A!C B
DAT1=A B
D=D-1 A
GONC rprlp
CD1EX
C=C+B A
CD1EX
A=DAT1 B
?ST=1 sPAR
GOYES +
A=A!C B
+ CSRB.F B
A=A!C B
DAT1=A B
GOVLNG =GETPTR
RPL
**********************************************************************
* More function dispatchees
**********************************************************************
**********************************************************************
LABEL addderiv
::
* Count der X's
CODE
GOSBVL =SAVPTR
GOSBVL =POP#
R0=A A N
CD1EX
D1=C
C=C+A A
A=A+A A
A=A+A A
C=C+A A
D=C A ->top
LC(5) =xDER
B=0 A ders
B=B-1 A
- B=B+1 A
A=DAT1 A
D1=D1+ 5
?A=C A
GOYES -
C=D A
D1=C ->top
LC(N) 5+2+2
CON(5) =DOIDNT
CON(2) 1
NIBASC 'X'
A=C W
D=0 A xses
D=D-1 A
- D=D+1 A
D1=D1- 5
A=DAT1 A
D0=A
A=DAT0 5+2+2
?A=C W
GOYES -
C=B A ders
?C<=D A
GOYES +
GOVLNG =GPPushFLoop
+ R0=C
GOSBVL =PUSH#
GOVLNG =PushTLoop
ENDCODE
case
* Multiple X derivatives, output ' form
::
DUP
CODE
GOLONG Push1Loop
ENDCODE
ZERO_DO (DO)
plDRPpZparg 2DROP
LOOP
LABEL dertick
CODE
GOLONG Font8
ENDCODE
CODE
GOLONG Pop1Loop
ENDCODE
NULL$SWAP ZERO_DO (DO) "'" !append$ LOOP
CODE
GOLONG $small
ENDCODE
THREE
CODE
GOTO AddExp
ENDCODE
;
* Collect variables
NULLPAINT ZERO
BEGIN
CODE
D1=D1+ 15
A=DAT1 A
D1=D1- 15
LC(5) =xDER
?A=C A
GOYES +
+ GOVLNG =PushT/FLoop
ENDCODE
WHILE
CODE
GOLONG Push2Loop
ENDCODE
plDRPpZparg DROP
CODE
GOLONG addobj
ENDCODE
"\88"
CODE
GOLONG $>font
ENDCODE
CODE
GOSUBL Insert!
GOSUBL Pop2
GOLONG InsertG
ENDCODE
REPEAT
LABEL derivmerge
( Meta G m )
4PICK TYPEIDNT? case
::
ROTDROP ROT
CODE
GOLONG addobj
ENDCODE
"\88"
CODE
GOLONG $>font
ENDCODE
CODE
GOSUBL Insert!
GOSUBL Swap2
GOTO AddDiv
ENDCODE
;
"\88"
CODE
GOLONG ObMisc
ENDCODE
CODE
GOSUBL Swap2
GOSUB AddDiv!
GOSUBL Push2
GOLONG Font6
ENDCODE
CODE
GOSUBL Pop2
GOLONG InsertG
ENDCODE
;
**********************************************************************
LABEL addintg
::
plDRPpZparg ( [Id] [Rest] )
pshzerpsharg ( [Id] [Expr] [Rest] )
unroll2ND ( [Rest] [Id] [Expr] )
CODE
GOLONG Font0
ENDCODE
ROTDROP ROT ( [Rest] g #mid id )
CODE
GOLONG ObIdnt ( [Rest] g #mid gid #m )
ENDCODE
"d"
CODE
GOLONG ObMisc ( [Rest] g #mid gid #m gd #md )
ENDCODE
CODE
GOSUBL InsertG! ( [Rest] g #mid g' #m' )
GOSUBL Swap2
GOLONG InsertG ( [Rest] g' #m' )
ENDCODE
3PICK #3+ UNROLL OVER #3+ UNROLL
pshzerpsharg ( I [Hi] [Lo] )
LABEL intglimit
::
CODE
TstIspc GOSBVL =SAVPTR
LC(5) =ONE
A=DAT1 A
?A#C A
GOYES notIspc
D1=D1+ 5
A=DAT1 A
D1=A
A=DAT1 5+2+2
C=A W
NIBHEX 38
CON(5) =DOIDNT
CON(2) 1
NIBASC '?'
?A#C W
GOYES notIspc
notIspc GOVLNG =GPPushT/FLp
ENDCODE
NOTcase2drop NULLPAINT
CODE
GOLONG FontIt-
ENDCODE
CODE
D1=D1+ 5
D=D+1 A
GOLONG FNT+LOOP
ENDCODE
;
OVER #2+ UNROLL
CODE
A=PC
LC(5) (intglimit)-(*)
A=A+C A
PC=(A)
ENDCODE
( g1 h1 g2 g3 )
DUPGROBDIM 4PICK GROBDIM 8PICK GROBDIM
( 10 9 8 7 6 5 4 3 2 1 )
( g1 h1 g2 g3 y3 x3 y2 x2 y1 x1 )
' NULLLAM 10 NDUPN DOBIND
* Create result grob
2GETLAM 4GETLAM #+ 6GETLAM #+ ( y1+y2+y3 )
3GETLAM #2+ 5GETLAM #MAX #2/ #1+ ( max[x2+2,x3]/2+1 )
5GETLAM 3GETLAM #MAX #1+ #2/ ( [max[x3,x2]+1]/2 )
1GETLAM #5+ ( x1+5 )
#MAX #+ MAKEGROB
* Bang G1
10GETLAM OVER
3GETLAM #2+ 5GETLAM #MAX #2/
#4+ 6GETLAM GROB!
* Bang G2
8GETLAM OVER
3GETLAM #2+ 5GETLAM #MAX #2/ #1+
3GETLAM #1+ #2/ #-
2GETLAM 6GETLAM #+ GROB!
* Bang G3
7GETLAM OVER
3GETLAM #2+ 5GETLAM #MAX #2/
#2+ 5GETLAM #2/ #- ZERO GROB!
* Draw integral
( 10 9 8 7 6 5 4 3 2 1 )
( g1 h1 g2 g3 y3 x3 y2 x2 y1 x1 )
2GETLAM #3- ONE MAKEGROB INVGROB ( Ysize = y1-3 )
OVER
3GETLAM #2+ 5GETLAM #MAX #2/ #1+ ( Xpos = max[x2+2,x3]/2+1 )
6GETLAM #1+ GROB! ( Ypos = y3+1 )
GROB E 20000200001020 OVER
3GETLAM #2+ 5GETLAM #MAX #2/ #2+ ( Xpos = max[x2+2,x3]/2+2 )
6GETLAM GROB! ( Ypos = y3 )
GROB E 20000200001020 OVER
3GETLAM #2+ 5GETLAM #MAX #2/ #1- ( Xpos = max[x2+2,x3]/2-1 )
6GETLAM 2GETLAM #+ #3- GROB! ( Ypos = y3+y1-3 )
9GETLAM 6GETLAM #+ ( Mid = h1+y3 )
ABND
;
**********************************************************************
LABEL addsum
::
plDRPpZparg
pshzerpsharg pshzerpsharg
DROP ID>$ CHR = >T$
CODE
GOLONG $small
ENDCODE
CODE
GOSUBL Push1
GOSUBL FNT-
GOLONG FontIt-
ENDCODE
CODE
GOSUBL Pop1
GOSUBL Insert!
D1=D1+ 5
D=D+1 A
GOSUBL Push1
GOLONG Font0
ENDCODE
CODE
GOSUBL FNT+
GOSUBL FNT+
D1=D1+ 5 DROP
D=D+1 A
GOLONG Pop1Loop
ENDCODE
GROB 52 2100001000FFFFFFFFD0088100030006000C000810003008100C00060003008100D008FFFFFFFF0000
( [Expr] Hi Lo Sig )
DUPGROBDIM 4PICK GROBDIM 7PICK GROBDIM
( 9 8 7 6 5 4 3 2 1 )
( H L S Sy Sx Ly Lx Hy Hx )
' NULLLAM 9 NDUPN DOBIND
* Make result grob
2GETLAM 4GETLAM #+ 6GETLAM #+
1GETLAM 3GETLAM #MAX 5GETLAM #MAX
MAKEGROB
* Put high limit
9GETLAM OVER
DUPGROBDIM SWAPDROP 1GETLAM #- #2/
ZERO GROB!
( 9 8 7 6 5 4 3 2 1 )
( H L S Sy Sx Ly Lx Hy Hx )
* Put low limit
8GETLAM OVER
DUPGROBDIM SWAPDROP 3GETLAM #- #2/
2GETLAM 6GETLAM #+ GROB!
* Put Sigma
7GETLAM OVER
DUPGROBDIM SWAPDROP 5GETLAM #- #2/
2GETLAM GROB!
* Output middle
6GETLAM #2/ 2GETLAM #+
ABND
CODE
GOSUBL Push2
GOLONG Font0
ENDCODE
CODE
GOSUBL AddPar!
GOSUBL Pop2
GOLONG InsertG
ENDCODE
;
**********************************************************************
LABEL addwhere
::
#2- UNROTDROP #2/
CODE
GOLONG Push1Loop
ENDCODE
LABEL takeequ
::
TWO TWO SCANAHEAD
#2- 2DUP #- ROTDROP OVER#2+UNROLL
' x= SWAP#1+
CODE
GOLONG FontIt-
ENDCODE
CODE
GOLONG FNT+LOOP
ENDCODE
;
CODE
GOLONG Pop1Loop
ENDCODE
DUP#1= ITE
DROP ( --> Meta G #M )
::
ONE_DO (DO)
CODE
GOSUBL Push2 Save current grob
A=PC
LC(5) (takeequ)-(*)
A=A+C A
PC=(A) Fetch next equate
ENDCODE
","
CODE
GOSUBL FNT- "," must be in the smaller font too!
GOLONG Pop2RotFont$
ENDCODE
CODE
GOSUBL FNT+
GOLONG Middle Merge new equate into old one
ENDCODE
LOOP
;
CODE
GOSUBL Push2
GOLONG Font0
ENDCODE
CODE
GOLONG Pop2Loop
ENDCODE
* g1 m1 g2 m2
DROP DUPGROBDIM
5PICK GROBDIM
* g1 m1 g2 y2 x2 y1 x1
ROT#+ #2+ UNROT #+SWAP
MAKEGROB
* g1 m1 g2 G
4PICK OVER ZEROZERO GROB!
* g1 m1 g2 G
SWAP OVER 5PICK GROBDIM #2+
SWAP GROB!
* g1 m1 G
SWAP ROT
CODE
GOSBVL =PopASavptr
D0=A
D0=D0+ 15
A=DAT0 A
B=A A x
D1=D1+ 5
C=DAT1 A
D1=C
D1=D1+ 10
C=DAT1 A
D=C A h
D1=D1+ 5
A=DAT1 A w
D1=D1+ 5
GOSBVL =w->W W
C=B A
CSRB.F A
CSRB.F A x/4
AD1EX
A=A+C A
AD1EX
LC(1) 3
C=C&B P
P=C 0
LCHEX 1248
P=C 3
C=0 A
CPEX 0 bit
B=A A W
- A=DAT1 B
A=A!C P
DAT1=A B
AD1EX
A=A+B A
AD1EX
D=D-1 A
?D#0 A
GOYES -
GOVLNG =GETPTRLOOP
ENDCODE
;
**********************************************************************
LABEL addabs
::
CODE
GOSUBL Pull
GOLONG Font0
ENDCODE
CODE
AddAbs GOSBVL =SAVPTR
D1=D1+ 5
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A y
R1=A
D0=D0+ 5
A=DAT0 A x
A=A+CON A,4 x+4
R0=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
GOSBVL =D1=DSKTOP
D1=D1+ 5
C=DAT1 A g
CD0EX
DAT1=C A
D1=C
RSTK=C
C=0 A
R0=C y'
LC(1) 2
R1=C x'
GOSUBL grb!
C=RSTK
R0=C G
D1=C
D1=D1+ 10
A=DAT1 A
R1=A y
D1=D1+ 5
A=DAT1 A w
R2=A
D1=D1+ 5
GOSBVL =w->W W
B=A A
* + *****+
* + *****+
* + *****+
* + *****+
* *****
C=R1 y
C=C-CON A,2
D=C A
LC(1) 1
lablp A=DAT1 B
A=A!C P
DAT1=A B
CD1EX
C=C+B A
CD1EX
D=D-1 A
GONC lablp
A=R0 G
D1=A
D1=D1+ 10
D1=D1+ 10
C=R1 y
C=C-CON A,2 y-2
D=C A
A=R2 w
A=A-CON A,2 w-2
LC(1) 3
C=C&A P
ASRB.F A
ASRB.F A
CD1EX
C=C+A A
CD1EX
P=C 0
LCHEX 1248
P=C 3
C=0 B
CPEX 0
rablp A=DAT1 B
A=A!C B
DAT1=A B
CD1EX
C=C+B A
CD1EX
D=D-1 A
GONC rablp
GOVLNG =GETPTRLOOP
ENDCODE
;
**********************************************************************
LABEL addxroot
::
CODE
GOLONG part1font0
ENDCODE
CODE
GOSUBL PopSave
GOLONG FontIt-
ENDCODE
CODE
GOSUBL FNT+
D1=D1+ 5
D=D+1 A
GOSUBL Pop2
GOLONG AddSqrt
ENDCODE
DUP EIGHT #MIN
4PICK GROBDIM DROP
2DUP#> ITE
:: 2DROP ZERO ;
SWAP#-
DUPUNROT #+SWAP
4PICK GROBDIMw 4PICK GROBDIM
ROT#+ #2- UNROTSWAP #+SWAP
MAKEGROB
( g1 g2 mid G )
ROTOVER DUPGROBDIM 4PICK GROBDIM
ROTSWAP #- UNROT #- GROB!
( g1 mid G )
ROTOVER ZEROZERO GROB!
SWAP
;
**********************************************************************
* Special functions
**********************************************************************
ASSEMBLE
IF fFANCYUSER
RPL
* All the special function name dispatchees must leave out the 1st DOCOL
**********************************************************************
LABEL addfp
(::)
CODE
D1=D1+ 10 2DROP
D=D+1 A
D=D+1 A
GOLONG FontIt+
ENDCODE
CODE
GOLONG FNT-LOOP
ENDCODE
;
**********************************************************************
LABEL addfm
(::)
CODE
D1=D1+ 10 2DROP
D=D+1 A
D=D+1 A
GOLONG FontIt-
ENDCODE
CODE
GOLONG FNT+LOOP
ENDCODE
;
**********************************************************************
LABEL addIf
(::)
2DROP splitonearg
CODE
GOLONG Font0
ENDCODE
CODE
GOSUBL Push2
GOLONG Font0
ENDCODE
CODE
GOLONG Pop2Loop
ENDCODE
2SWAP " ,"
CODE
GOLONG $>font
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addGrad
(::)
2DROP
CODE
GOLONG Font8
ENDCODE
GROB 16 6000060000F111A0A04000
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addDiv
(::)
2DROP
CODE
GOLONG Font8
ENDCODE
GROB 22 60000C0000F1001100A810A81040000000
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addCurl
(::)
2DROP
CODE
GOLONG Font8
ENDCODE
GROB 22 60000C0000F5401920A010A82044400000
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addLap
(::)
2DROP
CODE
GOLONG Font8
ENDCODE
GROB 3A C0000A00000C1000100C1004000C10F1001100A000A000400000000000
EIGHT
CODE
GOLONG InsertG
ENDCODE
;
**********************************************************************
LABEL addLapT
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG AddPar
ENDCODE
GROB 3E D0000B00008C0042104A0087000200020002000200C20023002500C8100000
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addILapT
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG AddPar
ENDCODE
GROB 3E D0000B00008C0042104A0087000200020002000200C20023002500C8100000
SIX "-1"
CODE
itransfirst GOSUBL FNT-
GOLONG ObMisc
ENDCODE
CODE
itranslast GOSUBL FNT+
GOSUBL AddExp!
GOLONG InsertG
ENDCODE
;
**********************************************************************
LABEL addFouT
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG AddPar
ENDCODE
GROB 3E D0000D0000C10026802870C80008000C000A200C1008000800440083000000
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addIFouT
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG AddPar
ENDCODE
GROB 3E D0000D0000C10026802870C80008000C000A200C1008000800440083000000
SIX "-1"
CODE
GOTO itransfirst
ENDCODE
CODE
GOTO itranslast
ENDCODE
;
**********************************************************************
LABEL addCross
(::)
2DROP splitonearg
CODE
GOLONG Font7
ENDCODE
CODE
GOSUBL Push2
GOLONG Font7
ENDCODE
"\D7"
CODE
GOLONG Pop2RotFont$
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addMul
(::)
2DROP splitonearg
CODE
GOLONG Font6
ENDCODE
CODE
GOSUBL Push2
GOLONG Font6
ENDCODE
CODE
GOSUBL Pop2
GOSUBL Swap2
GOLONG InsertG
ENDCODE
;
**********************************************************************
LABEL addPM
(::)
2DROP splitonearg
CODE
GOLONG Font6
ENDCODE
CODE
push2font5 GOSUBL Push2
GOLONG Font5
ENDCODE
CODE
GOSUBL Pop2
choosepm GOSUBL GChoose:
NIBHEX E1B2071000400004000020702070
NIBHEX E1B20B100060000600004040F14040F1
NIBHEX E1B20B100060000600004040F14040F1
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addpm
(::)
2DROP
CODE
GOLONG Font6
ENDCODE
CODE
GOTO choosepm
ENDCODE
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addMP
(::)
2DROP splitonearg
CODE
GOLONG Font6
ENDCODE
CODE
GOTO push2font5
ENDCODE
CODE
GOSUBL Pop2
choosemp GOSUBL GChoose:
NIBHEX E1B2071000400004000070207020
NIBHEX E1B20B10006000060000F14040F14040
NIBHEX E1B20B10006000060000F14040F14040
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL addmp
(::)
2DROP
CODE
GOLONG Font6
ENDCODE
CODE
GOTO choosemp
ENDCODE
CODE
GOLONG Insert
ENDCODE
;
**********************************************************************
LABEL addSo
(::)
2DROP splitonearg
CODE
GOLONG Font4
ENDCODE
CODE
push2font4 GOSUBL Push2
GOLONG Font4
ENDCODE
GROB 22 60000C00000800EF100020EF1008000000
CODE
GOLONG mergemiddle
ENDCODE
;
**********************************************************************
LABEL addEqu
(::)
2DROP splitonearg
CODE
GOLONG Font4
ENDCODE
CODE
GOTO push2font4
ENDCODE
GROB 22 60000010008080CFF12002CFF180800000
CODE
GOLONG mergemiddle
ENDCODE
;
**********************************************************************
LABEL addPar
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
CODE
GOLONG AddPar
ENDCODE
;
**********************************************************************
LABEL addLt
(::)
DUP#0=ITE
DROP
::
CODE
callTop A=PC
LC(5) (addTop)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
;
CODE
GOSBVL =POP#
GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 10
C=DAT0 A Y
D0=D0+ 5
A=DAT0 A X
A=A+CON A,5 X+5
C=C+CON A,2 Y+2
R0=A
R1=C
GOSBVL =makegrob
A=D0
LC(5) 20
A=A-C A
AR3EX ->G
B=A A W
LCHEX C
DAT0=C P
CD0EX
C=C+B A
CD0EX
C=R1 Y+2
C=C-CON A,4 Y-2
D=C A
DSRB.F A (Y-2)/2
C=C-D A Y-2-(Y-2)/2
LAHEX 2
- C=C-1 A
GOC +
DAT0=A P
CD0EX
C=C+B A
CD0EX
GONC -
+ LAHEX 1
DAT0=A P
CD0EX
C=C+B A
CD0EX
LAHEX 2
- D=D-1 A
GOC +
DAT0=A P
CD0EX
C=C+B A
CD0EX
GONC -
+ LCHEX C
DAT0=C P
GOSBVL =D1=DSKTOP
A=DAT1 A ->g
C=R3 A ->G
DAT1=C A
D1=C
D0=A
C=0 A
C=C+1 A
R0=C Y
LC(1) 5
R1=C X
GOSUBL grb!
GOSBVL =D1=DSKTOP
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A
ASRB.F A
GOVLNG =PUSH#ALOOP
ENDCODE
;
**********************************************************************
LABEL addRt
(::)
DUP#0=ITE
DROP
::
CODE
GOTO callTop
ENDCODE
;
CODE
GOSBVL =POP#
GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 10
C=DAT0 A Y
D0=D0+ 5
A=DAT0 A X
A=A+CON A,5 X+5
C=C+CON A,2 Y+2
R0=A
R1=C
GOSBVL =makegrob
A=D0
LC(5) 20
A=A-C A
AR3EX ->G
B=A A W
C=R1 Y+2
C=C-CON A,4 Y-2
D=C A
DSRB.F A (Y-2)/2
C=C-D A Y-2-(Y-2)/2
CDEX A
R1=C (Y-2)/2
A=R0 X+5
A=A-CON A,5 X
LC(1) 3
C=C&A P
ASRB.F A
ASRB.F A
CD0EX
C=C+A A
CD0EX
C=C+C P
C=C+C P
P=C 0
LCHEX 0806100C20180403
P= 0
A=DAT0 B
A=A!C B
DAT0=A B
AD0EX
A=A+B A
AD0EX
CSRC
CSRC
- D=D-1 A
GOC +
A=DAT0 B
A=A!C B
DAT0=A B
AD0EX
A=A+B A
AD0EX
GONC -
+ C=C+C A
A=DAT0 B
A=A!C B
DAT0=A B
CSRB.F A
AD0EX
A=A+B A
AD0EX
CR1EX
D=C A
CR1EX
- D=D-1 A
GOC +
A=DAT0 B
A=A!C B
DAT0=A B
AD0EX
A=A+B A
AD0EX
GONC -
+ CSLC
CSLC
A=DAT0 B
A=A!C B
DAT0=A B
GOSBVL =D1=DSKTOP
A=DAT1 A ->g
C=R3 A ->G
DAT1=C A
D1=C
D0=A
C=0 A
R1=C X
C=C+1 A
R0=C Y
GOSUBL grb!
GOSBVL =D1=DSKTOP
A=DAT1 A
D0=A
D0=D0+ 10
A=DAT0 A
ASRB.F A
GOVLNG =PUSH#ALOOP
ENDCODE
;
**********************************************************************
LABEL addVector
(::)
2DROP
CODE
GOLONG Font0
ENDCODE
#4+ SWAP
DUPGROBDIM 4 #MAX
SWAP #4+ SWAP MAKEGROB
DUPUNROT
2DUP GROBDIMw SWAP GROBDIMw
#- #2/ FOUR GROB!
GROB 10 3000020000103010
OVERDUP GROBDIMw #3- ZERO GROB!
ONE OVER GROBDIMw #3- MAKEGROB
INVGROB OVER ZERO ONE GROB!
SWAP
;
**********************************************************************
LABEL addTop
(::)
SWAPDROP
DUP 3PICK #3+ UNROLL
ZERO_DO (DO)
splitonearg
CODE
GOLONG Font0
ENDCODE
DROP OVER #3+ UNROLL
LOOP
DROP
CODE
formtop GOSBVL =POP#
GOSBVL =SAVPTR
R4=A
B=A A Y=N
B=B+B A
B=B+B A Y=N*4
D=0 A X=0
- C=DAT1 A
D1=D1+ 5
D0=C
D0=D0+ 10
C=DAT0 A y
B=B+C A Y += y
D0=D0+ 5
C=DAT0 A x
?D>=C A
GOYES +
D=C A X = max x
+ A=A-1 A
?A#0 A
GOYES -
C=D A X
A=B A Y
C=C+CON A,4 X+4
R0=C
R1=A
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
GOSUB GetIRAM
AD0EX
DAT1=A A
D1=D1+ 5
A=R4 N
DAT1=A A
D1=D1+ 5
C=0 A
DAT1=C A j
D1=D1+ 5
LCHEX 2
DAT1=C A y
D1=D1- 5
C=DAT1 A j
toploop GOSBVL =D0=DSKTOP
AD0EX
A=A+C A
C=C+C A
C=C+C A
A=A+C A
D0=A
A=DAT0 A
D0=A ->g
D1=D1+ 5
C=0 A
R1=C x
C=DAT1 A y
R0=C
D0=D0+ 10
A=DAT0 A yj
D0=D0- 10
C=C+A A y+yj
C=C+CON A,4
DAT1=C A y'
D1=D1- 15
A=DAT1 A ->G
D1=A
GOSUBL grb!
GOSUB GetIRAM
D1=D1+ 5
A=DAT1 A N
D1=D1+ 5
C=DAT1 A j
C=C+1 A j++
DAT1=C A
?C<A A
GOYES toploop
D1=D1- 10
C=DAT1 A ->G
R0=C
GOSBVL =GETPTR
C=A A N
D=D+C A N++
AD1EX
A=A+C A
C=C+C A
C=C+C A
A=A+C A
AD1EX
C=R0
D1=D1- 5
D=D-1 A
DAT1=C A
CD0EX
D0=D0+ 10
A=DAT0 A
CD0EX
ASRB.F A
GOVLNG =push#a
GetIRAM D1=(5) (=IRAM@)-4
C=DAT1 A
LCHEX 0100
D1=C
RTN
ENDCODE
;
**********************************************************************
* Add derivative in the tick form
**********************************************************************
LABEL addDer
(::)
2DROP ( --> MetaFull )
splitonearg ( --> Meta MetaDer )
OVER TYPEREAL? ITE
::
OVER %FP %0= NOTcaseFALSE ( Non-integer - show with [] )
OVER %1 %< caseFALSE ( < 1 - show with [] )
OVER %4 %<= ( If 1<=der<=4 then use ' )
;
FALSE
casedrop
::
COERCE ( Meta #n )
CODE
GOSUBL Push1
A=PC
LC(5) (dertick)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
;
CODE
GOLONG FontIt-
ENDCODE
CODE
GOLONG AddPar
ENDCODE
CODE
GOSUBL Push2 Save 'exponent'
GOSUBL FNT+
GOLONG Font8
ENDCODE
CODE
GOSUBL Pop2 Pop exponent
GOLONG AddExp
ENDCODE
;
**********************************************************************
* Add derivative with respect to given expression
**********************************************************************
LABEL addDER
(::)
2DROP ( --> MetaFull )
splitonearg ( --> Meta MetaDer )
CODE
GOLONG Font0 ( Meta dgrob #mid )
ENDCODE
"d"
CODE
GOLONG ObMisc ( Meta dgrob #mid d #m )
ENDCODE
OVER 5UNROLL DUP 5UNROLL ( Meta d #m dgrob #mid d #m )
CODE
GOSUBL InsertG! ( Meta d #m G1 #M1 )
GOSUBL AddDiv! ( Meta G2 #M2 )
GOSUBL Push2 ( Meta )
GOLONG Font8 ( g #m )
ENDCODE
CODE
GOSUBL Pop2 ( g #m G2 #M2 )
GOLONG InsertG ( G #M )
ENDCODE
;
**********************************************************************
* Add partial derivatives with respect to given expressions
**********************************************************************
LABEL addder
(::)
SWAPDROP ( --> Meta #args )
NULLPAINT ZERO
ROT ONE_DO (DO) ( Meta g #m )
CODE
GOLONG Push2Loop
ENDCODE
splitonearg
CODE
GOLONG Font7
ENDCODE
"\88"
CODE
GOLONG $>font
ENDCODE
CODE
GOSUBL Insert!
GOSUBL Pop2
GOLONG InsertG
ENDCODE
LOOP
CODE
A=PC
LC(5) (derivmerge)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
;
**********************************************************************
LABEL fun.n
(::)
#1-SWAP ( Meta #args-1 name )
ID>$ DUPLEN$ #2- ONESWAP SUB$ $>ID ( Meta #args-1 name' )
TWO psh ( #args-1 name' 2 Meta )
TWO OVER #5+ PICK ( #args-1 name' 2 Meta 2 #args-1 )
DUP#0=ITE
:: 2DROP pshzer ; ( #args-1 name' 2 0 Metan )
:: SCANAHEAD #1- rpnsplit ; ( #args-1 name' 2 Meta' Metan )
CODE
GOLONG FontIt- ( #args-1 name' 2 Meta' ngrob #mid )
ENDCODE
CODE
D1=D1+ 5 ( #args-1 name' 2 Meta' ngrob )
D=D+1 A
GOLONG FNT+LOOP
ENDCODE
SWAP#1+ psh DROPROT
#1-UNROT 4ROLLSWAP ( Meta #args-1 ngrob name' )
CODE
GOLONG ObIdnt ( Meta #args-1 ngrob grob #mid )
ENDCODE
ROTDUP ( Meta #args-1 grob #mid ngrob dummy )
CODE
GOLONG AddSubscript ( Meta #args-1 grob' #mid )
ENDCODE
CODE
GOLONG addfunargs ( --> g #m )
ENDCODE
;
**********************************************************************
LABEL fun.nm
(::)
#2- SWAP ( Meta #args-2 name )
ID>$ DUPLEN$ #3- ONESWAP SUB$ $>ID ( Meta #args-2 name' )
TWO psh ( #a-2 n' 2 Meta )
TWO OVER #5+ PICK ( #a-2 n' 2 Meta 2 #args-2 )
DUP#0=ITE
:: 2DROP pshzer ; ( #a-2 n' 2 #0 Metanm )
:: SCANAHEAD #1- rpnsplit ; ( #a-2 n' 2 Meta' Metanm )
splitonearg ( #a-2 n' 2 Meta' Metan Metam )
CODE
GOLONG FontIt- ( #a-2 n' 2 Meta' Metan mgrob #mmid )
ENDCODE
TWO psh
CODE
GOLONG Font0 ( #a-2 n' 2 Meta' mgrob #m 2 ngrob #n )
ENDCODE
CODE
D1=D1+ 5 ( #a-2 n' 2 Meta' mgrob #m 2 ngrob )
D=D+1 A
GOLONG FNT+LOOP
ENDCODE
SWAPDROP THREE roll2ND DROP ROTDROP ( Meta' mgrob #m ngrob #a-2 name' )
CODE
GOLONG ObIdnt ( Meta' mgrob #m ngrob #a-2 grob #g )
ENDCODE
6ROLL 6ROLL ( Meta' ngrob #a-2 grob #g mgrob #m )
4PICK GROBDIMw 5UNROLL ( Meta' ngrob #a-2 #w g #g m #m )
CODE
GOLONG AddExp ( Meta' ngrob #a-2 #w G #M )
ENDCODE
* Now add the subscript but at x-position #w instead of #W
* Xsize = max(X,w+x) Xpos = w Mid = M
* Ysize = Y+y-2 Ypos = Y-2
5ROLL DUPGROBDIM ( Meta' #a-2 #w G #M n y x )
5PICK GROBDIM ( Meta' #a-2 #w G #M n y x Y X )
OVER 5ROLL #+ #2- ( Meta' #a-2 #w G #M n x Y X Y+y-2 )
8PICK 5ROLL #+ ROT #MAX ( Meta' #a-2 #w G #M n Y Ysize max[w+x,X] )
MAKEGROB ( Meta' #a-2 #w G #M n Y G' )
5ROLL OVER ( Meta' #a-2 #w #M n Y G' G G' )
ZEROZERO GROB! ( Meta' #a-2 #w #M n Y G' )
ROTOVER ( Meta' #a-2 #w #M Y G' n G' )
6ROLL 5ROLL #2- ( Meta' #a-2 #M G' n G' w Y-2 )
GROB! ( Meta' #a-2 #M G' )
SWAP
CODE
GOLONG addfunargs ( --> g #m )
ENDCODE
;
**********************************************************************
ASSEMBLE
ENDIF * fFANCYUSER
RPL
**********************************************************************
* Regular Objects
**********************************************************************
ASSEMBLE
addobj C=0 A
R0=C.F A 0-priority
addobj.1 C=DAT1 A
CD0EX
A=DAT0 A
CD0EX
GOSUB obdispatch:
CON(5) =DOREAL
REL(5) obreal
CON(5) =DOIDNT
REL(5) obidnt
CON(5) =DOLAM
REL(5) oblam
CON(5) =DOEXT
REL(5) obunit
CON(5) =DOARRY
REL(5) obarry
CON(5) =DOLIST
REL(5) oblist
CON(5) =DOGROB
REL(5) obgrob
CON(5) =DOROMP
REL(5) obromp
CON(5) =DOTAG
REL(5) obtag
CON(5) 0
REL(5) obmisc
obdispatch: C=RSTK
CD0EX
RSTK=C
- C=DAT0 A
D0=D0+ 10
?C=0 A
GOYES +
?A#C A
GOYES -
+ D0=D0- 5
A=DAT0 A
C=RSTK
CD0EX
A=A+C A
PC=(A)
RPL
**********************************************************************
LABEL obtag
::
'EvalNoCK: xOBJ> $>ID
CODE
GOTO ObIdnt
ENDCODE
ROT
CODE
GOLONG FontOb
ENDCODE
": "
CODE
GOLONG $>font
ENDCODE
CODE
GOLONG Middle
ENDCODE
;
**********************************************************************
LABEL obreal
::
CODE
A=R0 A Push false if large priority..
LC(5) (PRI7)-(PORG)
?A<C A
GOYES +
C=DAT1 A .. and number is negative
CD0EX
D0=D0+ 5
A=DAT0 W
CD0EX
?A=0 S
GOYES +
+ GOVLNG =PushT/FLoop
ENDCODE
SWAP a%>$
CODE
GOTO ObMisc
ENDCODE
ROT NOTcase ( Add parenthesis if needed )
CODE
GOLONG AddPar
ENDCODE
;
**********************************************************************
LABEL oblam
::
ID>$
CODE
GOTO ObMisc
ENDCODE
;
**********************************************************************
CODE
ObMisc A=PC
A=A+CON A,10
PC=(A)
ENDCODE
LABEL obmisc
::
CODE
C=DAT1 A
CD0EX
A=DAT0 A
D0=C
LC(5) =DOCSTR
?A=C A
GOYES +
* Hmm, how to handle this if stack decompile is on?
LA(5) =DO>STR
PC=(A)
+ GOVLNG =Loop
ENDCODE
CODE
GOLONG $>font
ENDCODE
LABEL obgrob
CODE
pushmid C=DAT1 A
CD0EX
D0=D0+ 10
A=DAT0 A Y
CD0EX
ASRB.F A Y/2
GOVLNG =push#a
ENDCODE
;
**********************************************************************
LABEL obromp
::
palrompdcmp DROP $>ID
CODE
GOTO ObIdnt
ENDCODE
;
**********************************************************************
LABEL obunit
::
DUPNULLCOMP? case
CODE
GOTO ObMisc
ENDCODE
>R ticR DROP
DTYPEREAL? ?SKIP
CODE
A=PC
LC(5) (unitcont)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
a%>$
CODE
GOTO ObMisc
ENDCODE
LABEL unitnext
ticR NOT?SEMI
LABEL unitcont
DTYPECSTR? case
::
CODE
GOTO ObMisc
ENDCODE
CODE
unext A=PC
LC(5) (unitnext)-(*)
A=A+C A
D0=A
GOVLNG =Loop
ENDCODE
;
DUPTYPECHAR? case
::
CHR>$
CODE
GOTO ObMisc
ENDCODE
CODE
GOTO unext
ENDCODE
;
DUPTYPEREAL? case
::
a%>$
CODE
GOTO ObMisc
ENDCODE
CODE
GOTO unext
ENDCODE
;
REQcasedrop umP
::
CODE
GOSUBL Swap2
GOSUBL InsertG!
GOTO unext
ENDCODE
;
REQcasedrop um*
::
GROB E 20000200001000
CODE
GOSUBL Middle!
GOTO unext
ENDCODE
;
REQcasedrop um/
::
CODE
GOSUBL AddDiv!
GOTO unext
ENDCODE
;
REQcasedrop um^
::
CODE
GOSUBL AddExp!
GOTO unext
ENDCODE
;
DROP
"_"
CODE
GOLONG $>font
ENDCODE
CODE
GOSUBL Middle!
GOTO unext
ENDCODE
;
*********************************
* Check special symbols
* Make dotted part a subindex
* Make trailing digits ..
*********************************
ASSEMBLE
ObIdnt A=PC
A=A+CON A,10
PC=(A)
RPL
LABEL obidnt
::
ASSEMBLE
IF fFANCYIDS
CON(5) =DOCODE
REL(5) ->obid10
GOSBVL =SAVPTR
GOSUB D0->ids
C=DAT1 A
D1=C
D1=D1+ 5
-- P= 0
D0=D0+ 5
A=DAT0 B
?A=0 B
GOYES ++
C=DAT1 B
?A=C B
GOYES +
?A>C B
GOYES ++
- C=0 A
C=A B
AD0EX
A=A+C A
A=A+C A
AD0EX
D0=D0+ 2
GOSBVL =SKIPOB
GONC --
+ C=C+C A
C=C+1 A
P=C 0
A=DAT0 WP
C=DAT1 WP
?A#C WP
GOYES -
CD0EX
C+P+1
A=C A
P= 0
GONC +
++ GOVLNG =GETPTRLOOP
+ GOSBVL =GETPTR
DAT1=A A
D0=A
A=DAT0 A
LC(5) =DOGROB
?A=C A
GOYES +
LC(5) =COLA_EVAL
GOVLNG =GETPTREVALC
+ D0=D0+ 10
A=DAT0 A
ASRB.F A
R0=A A
GOSBVL =PUSH#
GOVLNG (=SEMI)+5
D0->ids A=PC
D0=A
D0=D0+ 8
RTN
RPL
ID \9F
GROB 12 4000060000A05151A0
ID \9A
GROB 16 600006000090115151A000
ID Phi
GROB 1A 8000060000E0E0515151E0E000
ID phi
GROB 1A 8000070000219252E140502000
ID Psi
GROB 1A 800006000040515151E040E000
ID Cont
::
"\1F"
CODE
GOTO ObMisc
ENDCODE
;
ID Gamma
GROB 1A 8000060000F121202020207000
ID GAMMA
GROB 1A 8000060000F121202020207000
ID Nabla
GROB 16 6000060000F111A0A04000
ID Blank
::
" "
CODE
GOTO ObMisc
ENDCODE
;
ID Planck
GROB 1A 8000060000206030E021212100
ASSEMBLE
NIBHEX 84E2000 Nullid terminator
->obid10
ENDIF * fFANCYIDS
RPL
*********************************
* Check for dot *inside* body
*********************************
ID>$
ASSEMBLE
IF fFANCYDOT
CON(5) =DOCODE
REL(5) ->iddot
GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 5
C=DAT0 A
D0=D0+ 5
C=C-CON A,5
CSRB.F A chrs
D=C A
D=D-CON A,3
GOC nodot
B=0 A pos
LCASC '.'
B=B+1 A minpos
- B=B+1 A pos++
D0=D0+ 2
A=DAT0 B
?A=C B
GOYES gotdot
D=D-1 A
GONC -
nodot GOVLNG =GETPTRLOOP
newrpl: C=RSTK
D0=C
GOVLNG =Loop
gotdot A=B A
R0=A
GOSBVL =PUSH#
GOSUB newrpl:
RPL
2DUP ONESWAP #1- SUB$
CODE
GOTO ObMisc
ENDCODE
2SWAP #1+ MINUSONE SUB$
$>ID ONE
CODE
GOLONG FontIt-
ENDCODE
CODE
GOSUBL FNT+
GOTO AddSubscript
ENDCODE
SEMI
ASSEMBLE
->iddot
ENDIF * fFANCYDOT
RPL
*********************************
* No dot in idnt, try digits
*********************************
CODE
GOSBVL =SAVPTR Count trailing digits
A=DAT1 A
D0=A
D0=D0+ 5
C=DAT0 A
AD0EX
A=A+C A
D0=A
B=0 A
B=B-1 A
isnumlp B=B+1 A
D0=D0- 2
A=DAT0 B
LCASC '0'
?A<C B
GOYES nonnum
LC(1) 9
?A<=C B
GOYES isnumlp
nonnum A=B A
GOVLNG =PUSH#ALOOP
ENDCODE
DUP#0=csedrp
* No digits either
CODE
GOTO ObMisc
ENDCODE
* Found #n digits, check length
OVERLEN$ OVER#= casedrop
CODE
GOTO ObMisc
ENDCODE
* Ok to make subindex
OVER ONE OVERLEN$ 4PICK #- SUB$
( $ #n $1 )
CODE
GOTO ObMisc
ENDCODE
2SWAP
( g1 #mid1 $ #n )
OVERLEN$ SWAP#- #1+ MINUSONE SUB$
CODE
GOSUBL FNT-
GOTO ObMisc
ENDCODE
( g1 #mid1 g2 #mid2 )
CODE
GOSUBL FNT+
GOTO AddSubscript
ENDCODE
;
( g1 #mid1 g2 #mid2 )
CODE
AddSubscript
A=PC
A=A+CON A,10
PC=(A)
ENDCODE
::
DROP
DUPGROBDIM 5PICK GROBDIM
( g1 m1 g2 y2 x2 y1 x1 )
ROT#+ UNROT #+ #2-
( g1 m1 g2 xsize ysize )
SWAP MAKEGROB
( g1 m1 g2 G )
4PICK OVER ZEROZERO GROB!
( g1 m1 g2 G )
4ROLL GROBDIM SWAP #2-
( m1 g2 G x1 y1-2 )
3PICK 6UNROLL GROB!
( G m1 )
;
**********************************************************************
LABEL obarry
::
* Check for 1-2 dimensions
CODE
GOSBVL =SAVPTR
A=DAT1 A
D0=A
D0=D0+ 15
A=DAT0 A
?A=0 A
GOYES +
C=0 A
LC(1) 2
?A>C A
GOYES +
+ GOVLNG =GPPushT/FLp
ENDCODE
case
CODE
GOLONG ObMisc
ENDCODE
DUP ARSIZE #1+_ONE_DO (DO)
INDEX@ OVER GETATELN DROP
CODE
GOLONG FontOb
ENDCODE
ROT
LOOP
DIMLIMITS INNERCOMP
DUP #1<> IT DROP
CODE
GOTO FormArry
ENDCODE
CODE
GOLONG AddBra
ENDCODE
;
**********************************************************************
LABEL oblist
::
* First test matrix dimensions
* ( list --> list FALSE ) - not 1D or 2D
* ( list --> list #n ZERO TRUE ) - 1D
* ( list --> list #n #m TRUE ) - 2D
CODE
ListDim GOSBVL =SAVPTR
* If lenght = 0 then not matrix
* First count the number of elements
A=DAT1 A
D0=A
B=0 A elements=0
D0=D0+ 5
- A=DAT0 A
LC(5) =SEMI
?A=C A
GOYES +
B=B+1 A elements++
GOSBVL =SKIPOB
GOTO -
+
* If zero then NULL{}
?B=0 A
GOYES notmatrix
A=B A
R0=A A R0[A] = Y
* Check that all elements are lists or non-lists
A=DAT1 A
D0=A
D0=D0+ 5
A=DAT0 A
LC(5) =DOLIST
?A=C A
GOYES matrix2D?
* 1st element not list - check none of the others is
matrix1D? A=DAT0 A
LC(5) =DOLIST
?A=C A
GOYES notmatrix found list - not matrix
GOSBVL =SKIPOB
B=B-1 A
?B#0 A
GOYES matrix1D?
* Passed the 1D test - exit
C=0 A
R1=C A ZERO
GOSBVL =PUSH2#
GOVLNG =PushTLoop
* Failed test - not matrix
notmatrix GOVLNG =GPPushFLoop
* Test if matrix is 2D
sGOT1st EQU 5 Flag to indicate got first dimension
matrix2D? ST=0 sGOT1st Haven't calculated first X yet
matrix2Dloop A=DAT0 A
LC(5) =DOLIST
?A#C A
GOYES notmatrix Non-list element - fail
C=B A
RSTK=C Save counter
D0=D0+ 5 Count elements and verify no lists
B=0 A elements = 0
- A=DAT0 A
LC(5) =SEMI
?A=C A
GOYES +
LC(5) =DOLIST
?A=C A
GOYES notmatrix
B=B+1 A elements++
GOSBVL =SKIPOB
GOTO -
+ D0=D0+ 5 Skip SEMI
C=RSTK
CBEX A B[A]=Y C[A]=elements
CDEX A D[A]=elements C[A]=oldelements
?ST=0 sGOT1st
GOYES matrix2Dnxt Ignore equal X test - no 2nd X yet
?C#D A
GOYES notmatrix Not equal dimensions - fail
matrix2Dnxt ST=1 sGOT1st Have 1st X now
B=B-1 A
?B#0 A
GOYES matrix2Dloop Loop until passed all elements
?D=0 A
GOYES notmatrix Fail if 2nd dim == 0
C=D A
R1=C A 2nd dim
GOSBVL =PUSH2#
GOVLNG =PushTLoop
ENDCODE
NOTcase
CODE
GOLONG ObMisc
ENDCODE
* {} #y #x
* Handle 1D matrix
DUP#0= ITE ( {} #n #0 )
::
ROT ZERO NEXTCOMPOB DROP ( #n #0 {} #off ob1 )
BEGIN
CODE
GOLONG FontOb
ENDCODE
6UNROLL 6UNROLL ( ob #mid .. #n #0 {} #off )
NEXTCOMPOB
NOT_UNTIL (UNTIL)
DROP
;
* Handle 2D matrix
::
ROT ZERO NEXTCOMPOB DROP
BEGIN
ZERO NEXTCOMPOB DROP
BEGIN
CODE
GOLONG FontOb
ENDCODE
8UNROLL 8UNROLL
NEXTCOMPOB
NOT_UNTIL (UNTIL)
DROP NEXTCOMPOB
NOT_UNTIL (UNTIL)
DROP
;
DUP#0= IT #1+ ( Fix #0 to #1 )
CODE
GOTO FormArry
ENDCODE
CODE
GOLONG AddPar
ENDCODE
;
**********************************************************************
* Build array from grobs
* g1 m1 .. gn mn #y #x --> g m
**********************************************************************
ASSEMBLE
FormArry
ABASE 0
GRB ALLOC 5 FIRST!
XSIZE ALLOC 5
YSIZE ALLOC 5
ROW ALLOC 5
COLUMN ALLOC 5
XPOS ALLOC 5
YPOS ALLOC 5
STKPOS ALLOC 5
ROWMID ALLOC 5
ROWBOT ALLOC 5
GOSBVL =POP2#
R3=A A Y
R2=C A X
GOSBVL =SAVPTR
D1=(5) (=IRAM@)-4
C=DAT1 A
LC(4) #100
R4=C A
D1=C
D1=(2) XSIZE
C=R2
DAT1=C A
D1=(2) YSIZE
C=R3
DAT1=C A
* Calculate resulting grob size
* Xsize first
A=R2 A X
C=A A
C=C+C A
C=C+C A 4X
R0=C gaps
- GOSUB ColumnSize
C=R0 A
C=C+A A
R0=C A
A=R2 A
A=A-1 A
R2=A A
?A#0 A
GOYES -
* Ysize next
A=R3 A X
C=A A
C=C+C A
C=C+C A 4Y
R1=C gaps
- GOSUB RowSize
C=R1 A
C=C+A A
C=C+B A
R1=C A
A=R3 A
A=A-1 A
R3=A A
?A#0 A
GOYES -
* Create grob
GOSBVL =makegrob
D0=D0- 10
D0=D0- 10
C=R4 A
CD0EX
DAT0=C A GRB
* Start banging grobs
C=R4 A
D1=C
C=0 A
LC(1) 1
D1=(2) ROW
DAT1=C A
LC(1) 4/2
D1=(2) YPOS
DAT1=C A
D1=(2) XSIZE
A=DAT1 A
D1=(2) YSIZE
C=DAT1 A
GOSBVL =MUL#
A=B A
A=A+A A
A=A+A A
B=B+A A
B=B+B A 10XY
GOSBVL =D0=DSKTOP
A=A+B A
D1=(2) STKPOS
DAT1=A A
newrow C=R4 A
D1=C
D1=(2) ROW
A=DAT1 A
GOSUB RowSize
C=R4 A
RSTK=C
D1=C
D1=(2) ROWMID
DAT1=A A
D1=(2) ROWBOT
A=B A
DAT1=A A
D1=(2) COLUMN
C=0 A
LC(1) 1
DAT1=C A
D1=(2) XPOS
LC(1) 4/2
DAT1=C A
newcol C=RSTK
R4=C.F A
RSTK=C
D0=C
D0=(2) COLUMN
A=DAT0 A
GOSUB ColumnSize
R2=A A XMAX
D0=(2) XPOS
C=DAT0 A
R1=C A
C=C+A A
C=C+CON A,4
DAT0=C A
D0=(2) YPOS
C=DAT0 A
R0=C A
D0=(2) ROWMID
C=DAT0 A
D=C A
D0=(2) STKPOS
C=DAT0 A
C=C-CON A,10
DAT0=C A
D1=C
D1=D1+ 5
A=DAT1 A ->grob
D1=D1- 5
C=DAT1 A
D1=C
D1=D1+ 5
C=DAT1 A mid
D=D-C A MID-mid
C=R0 A
C=C+D A
R0=C A ypos
D0=(2) GRB
C=DAT0 A
D1=C
D0=A
D0=D0+ 15
A=DAT0 A x
D0=D0- 15
C=R2 A XMAX
C=C-A A
CSRB.F A
A=R1 A
A=A+C A
R1=A
GOSUBL grb!
C=RSTK
RSTK=C
D0=C
D0=(2) XSIZE
A=DAT0 A
D0=(2) COLUMN
C=DAT0 A
C=C+1 A
DAT0=C A
?C>A A
GOYES +
GOTO newcol
+ C=RSTK
R4=C A ->data
D0=(2) ROWMID
A=DAT0 A
D0=(2) ROWBOT
C=DAT0 A
A=A+C A
A=A+CON A,4
D0=(2) YPOS
C=DAT0 A
C=C+A A
DAT0=C A
D0=(2) YSIZE
A=DAT0 A
D0=(2) ROW
C=DAT0 A
C=C+1 A
DAT0=C A
?C>A A
GOYES +
GOTO newrow
+ D0=(2) GRB
A=DAT0 A
R0=A A ->GROB
D0=(2) XSIZE
A=DAT0 A
D0=(2) YSIZE
C=DAT0 A
GOSBVL =MUL# XY
A=B A
GOSBVL =GETPTR
C=D A
C=C+A A
D=C A
CD1EX
A=A+A A 2XY
C=C+A A
A=A+A A
A=A+A A 8XY
C=C+A A
CD1EX
A=R0 A ->AGROB
D1=D1- 5
D=D-1 A
DAT1=A A
GOSBVL =SAVPTR
D0=A
D0=D0+ 10
A=DAT0 A Y
ASRB.F A
GOVLNG =PUSH#ALOOP
*********************************
* A[A] = column (>=1)
* R4[A] = ->data
* Out:
* A[A] = maxx
*********************************
ColumnSize
C=A A
C=C+C A
C=C+C A
A=A+C A
A=A+A A 10i
C=R4 A
D1=C
D1=(2) YSIZE
C=DAT1 A
D=C A Y
D1=(2) XSIZE
C=DAT1 A
B=C A
C=C+C A
C=C+C A
B=B+C A
B=B+B A 10X
GOSBVL =D1=DSKTOP
C=C+B A
C=C-A A
D1=C
D1=D1+ 5 ->grob
A=0 A maxx
- C=DAT1 A
CD1EX
RSTK=C
D1=D1+ 15
C=DAT1 A x
?A>=C A
GOYES +
A=C A new maxx
+ C=RSTK
C=C+B A
D1=C
D=D-1 A
?D#0 A
GOYES -
RTN
*********************************
* A[A] = row (>=1)
* R4[A] = ->data
* Out:
* A[A] = maxmid
* B[A] = maxbot
*********************************
RowSize
C=R4 A
D1=C
D1=(2) =YSIZE
C=DAT1 A
C=C-A A Y-i
D1=(2) =XSIZE
A=DAT1 A X
GOSBVL =MUL#
C=DAT1 A
RSTK=C
GOSBVL =D1=DSKTOP
A=B A
A=A+A A
A=A+A A
A=A+B A
A=A+A A
C=C+A A
D1=C
A=0 A maxmid
B=0 A maxbot
- C=DAT1 A
CD1EX
RSTK=C
D1=D1+ 5
C=DAT1 A mid
?A>=C A
GOYES +
A=C A maxmid'
+ D=C A mid
C=RSTK
D1=C
D1=D1+ 5
C=DAT1 A
CD1EX
RSTK=C
D1=D1+ 10
C=DAT1 A y
C=C-D A bot
?B>=C A
GOYES +
B=C A maxbot'
+ C=RSTK
D1=C
D1=D1+ 5
C=RSTK
C=C-1 A
RSTK=C
?C#0 A
GOYES -
C=RSTK
RTN
**********************************************************************
* Miscellaneous Utilities
**********************************************************************
**********************************************************************
* Fast grob! replacement
**********************************************************************
g1ST EQU 0
MAXPIX EQU 15*4-3
*GRB! GOSBVL =POP2#
* R0=C
* R1=A
* C=DAT1 A
* RSTK=C ->target
* D1=D1+ 5
* D=D+1 A
* GOSBVL =PopASavptr
* D0=A
* C=RSTK
* D1=C
* GOSUB grb!
* GOVLNG =GETPTRLOOP
* Input:
* R0[A]=Y D0=->src
* R1[A]=X D1=->target
grb!
AR0EX.F A
AR1EX.F A
AR0EX.F A
D0=D0+ 5
C=DAT0 A
C=C-CON A,16
RTNC
D0=D0+ 5
C=DAT0 A
?C=0 A
RTNYES
D0=D0+ 5
A=DAT0 A
?A=0 A
RTNYES
D0=D0+ 5
B=A A gx
C=C-1 A lines-1
R4=C.F A
D1=D1+ 5
C=DAT1 A
C=C-CON A,16
RTNC
D1=D1+ 5
C=DAT1 A
?C=0 A
RTNYES
D1=D1+ 5
A=DAT1 A
?A=0 A
RTNYES
D1=D1+ 5
GOSBVL =w->W
R2=A.F A GW
* R0 X
* R1 Y
* R2 GW
* R4 lines-1
* B gx
C=R1.F A Y
-- SB=0 Skip top of G
CSRB.F A
?SB=0
GOYES +
CD1EX
C=C+A A
CD1EX
+ A=A+A A
?C#0 A
GOYES --
A=B A
GOSBVL =w->W
R1=A.F A gW
* R0 X
* R1 gW
* R2 GW
* R4 lines-1
* B gx
C=R0.F A X
CSRB.F A
CSRB.F A
AD1EX
A=A+C A GSKIP
AD1EX
LC(5) MAXPIX
?B<C A THIS WAS BUGGED (<=)
GOYES g!xs
GOTO g!xl
*********************************
* Narrow grob to bang
*********************************
g!xs C=0 A
C=R0.F P X
CBIT=0 3
CBIT=0 2 X&3
B=B+C A gx+shift
P=C 0 X&3
C=P 15 shift
LCHEX 0137
P=C 3
C=P 0 mask1
P= 0
A=B B
B=0 W
B=C P mask
C=A B
SB=0
CSRB.F B
?SB=0
GOYES g!x0
g!x1 SB=0
CSRB.F B
P=C 0 WP
?SB=0
GOYES g!01
g!11 LCHEX 8
GONC +
g!01 LCHEX E
GOC +
g!x0 CSRB.F B
P=C 0 WP
?SB=0
GOYES g!00
g!10 LCHEX C
GONC +
g!00 LCHEX F
+ B=B!C P mask
C=R4.F A lines-1
D=C A
-- A=DAT0 WP
A=C S shift
A=A-1 S
GOC +
A=A+A WP
A=A-1 S
GOC +
A=A+A WP
A=A-1 S
GOC +
A=A+A WP
+ C=DAT1 WP
C=C&B WP
B=-B-1 WP
A=A&B WP
B=-B-1 WP
A=A!C WP
DAT1=A WP
C=R1.F A gW
AD0EX
A=A+C A
D0=A
C=R2.F A GW
AD1EX
A=A+C A
D1=A
D=D-1 A
GONC --
P= 0
RTNCC
*********************************
* Wide grob to bang
*********************************
* R0 X
* R1 gW
* R2 GW
* R4 lines-1
* B gx
g!xl C=B A gx
CR0EX.F A
D=C A X
C=0 A
LC(1) 3
C=C&D P
D=C P X&3
B=B+C A gx+(X&3)
BSRB.F A
BSRB.F A
C=R1.F A
C=C-B A gskip
R1=C.F A
C=R2.F A
C=C-B A Gskip
R2=C.F A
C=D P
CSRC shift
C=R0.F P gx&F
C=C+D P
CBIT=0 3
CBIT=0 2
P=C 0
LCHEX FEC8
P=C 3
C=P 1
D=C B mask2
P=C 15
LCHEX 0137
P=C 3
C=P 0
P= 0
D=C P mask1
g!line A=R0.F A lpix
ST=1 g1ST
g!next R3=A.F A pix
C=0 A
LC(1) 4
?A<C A
GOYES g!last
B=A A
BSRB.F A
BSRB.F A nibs
LC(1) #E
?B<C A
GOYES +
B=C A
+ A=DAT0 W
GOSUB gshift
C=B P
P=C 0
P=P-1 nibs-1
B=B+B B
B=B+B B 4*nibs
* Mask if start of line
?ST=0 g1ST
GOYES +
CPEX 15
C=P 0
CPEX 15
B=B-C B
C=DAT1 1
C=C&D B
A=A!C B
?C=0 S
GOYES +
D0=D0- 1
+ DAT1=A WP
CD1EX
C+P+1
D1=C
CD0EX
C+P+1
D0=C
P= 0
ST=0 g1ST
A=R3.F A
A=A-B A
GOTO g!next
g!last ?A=0 A
GOYES +
A=DAT0 B
GOSUB gshift
B=A P
C=D B
CSR B
A=DAT1 B
A=A&C P
C=-C-1 P
B=B&C P
A=A!B P
DAT1=A P
+ A=R4.F A
A=A-1 A
RTNC
R4=A.F A
C=R1.F A
AD0EX
A=A+C A
AD0EX
C=R2.F A
AD1EX
A=A+C A
AD1EX
?C=0 S
GOYES +
D0=D0+ 1
+ GOTO g!line
gshift ?C=0 S
RTNYES
P=C 15
?ST=1 g1ST
GOYES +
- ASRB
P=P+1
?P# 4
GOYES -
P= 0
RTNCC
+
- A=A+A W
P=P-1
?P# 0
GOYES -
RTNCC
**********************************************************************
* General $ to grob conversion using FNT
**********************************************************************
$>font CD0EX
D0=(5) (=IRAM@)-4
A=DAT0 A
D0=A
D0=(4) FNT
A=DAT0 A A[A] = font size
D0=C
A=A+A A If size < 0 then use small font
GOC $small
ASRB.F A
A=A-CON A,2 1 --> -1
GOC $small
A=A-1 A 2 --> -1
GONC $big
GOTO $med
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Desc: Convert $ to large font grob
* Stack: ( $ --> grob )
* Notes: UFL has no standard large font
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$big GOVLNG (=$>BIGGROB)+5
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Desc: Convert $ to small font grob using UFL small font
* Stack: ( $ --> grob )
* Notes: Requires LAM #FNT1
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$small GOSBVL =SAVPTR
LC(N) 12
CON(2) 5
NIBASC '#FNT1'
GOSUB SearchLam
* GOC fonterror Should never happen
R4=A R4[A] = ->fnt1
GOSBVL =GetStrLenStk
C=C+C A
C=C+C A
R0=C R0[A] = X-size = 4*chars
C=0 A
LC(1) 6
R1=C R1[A] = Y-size = 6 pixels
GOSBVL =makegrob R3[A] = rownibbles
AD0EX
D0=A
LC(5) #14
A=A-C A
R0=A R0[A] = ->grob
GOSBVL =D1=DSKTOP
GOSBVL =GetStrLenStk
D=C A D[A] = chars
C=R3
B=C A B[A] = rownibbles
-- D=D-1 A D[A] = chars--
GOC fontok
A=0 A
A=DAT1 B A[A] = char
D1=D1+ 2
C=R4 C[A] = ->fnt1
A=A+A A
C=C+A A
A=A+A A
C=C+A A C[A] = ->fnt1 + 6*char
CD0EX
A=DAT0 6 A[0-5] = chardata
D0=C
- DAT0=A P Write chardata
AD0EX
A=A+B A
AD0EX
P=P+1
?P# 6
GOYES -
P= 0
D0=C
D0=D0+ 1
GONC --
fontok GOVLNG =GPOverWrR0Lp
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Desc: Convert $ to small font grob using UFL small font
* Stack: ( $ --> grob )
* Notes: Requires LAM #FNT2
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$med GOSBVL =SAVPTR
LC(N) 12
CON(2) 5
NIBASC '#FNT2'
GOSUB SearchLam
* GOC fonterror Should never happen
R4=A A R4[A] = ->fnt2
GOSBVL =GetStrLenStk
A=C A
A=A+A A
C=C+A A
C=C+C A
R0=C R0[A] = X-size = 6*chars
C=0 A
LC(1) 8
R1=C R1[A] = Y-size = 8 pixels
GOSBVL =makegrob R3[A] = rownibbles
AD0EX
D0=A
LC(5) #14
A=A-C A
R0=A R0[A] = ->grob
GOSBVL =D1=DSKTOP
GOSBVL =GetStrLenStk
D=C A D[A] = chars
C=R3
B=C A B[A] = rownibbles
ST=0 0 Flag even X-position
-- D=D-1 A D[A] = chars--
GOC fontok
A=0 A
A=DAT1 B A[A] = char
D1=D1+ 2
C=R4 C[A] = ->fnt2
ASL A
C=C+A A C[A] = ->fnt2 + 16*char
CD0EX
A=DAT0 W A[W] = chardata
D0=C
?ST=1 0
GOYES +
P= 16-8 Handle even X-position
- DAT0=A B
ASR W
ASR W
AD0EX
A=A+B A
AD0EX
P=P+1
GONC -
D0=C
D0=D0+ 1
ST=1 0
GONC --
+ RSTK=C Handle odd X-position
A=A+A W
A=A+A W
P= 16-8
- C=DAT0 B
?CBIT=0 0
GOYES +
ABIT=1 0
+ ?CBIT=0 1
GOYES +
ABIT=1 1
+ DAT0=A B
ASR W
ASR W
AD0EX
A=A+B A
AD0EX
P=P+1
GONC -
C=RSTK
D0=C
D0=D0+ 2
ST=0 0
GOTO --
*---------------------------------------------------------------------
* Search for the 5 character LAM name given in C[W] with length field
*---------------------------------------------------------------------
SearchLam D=C W D[W] = lam name
D0=(5) =aTEMPENV
A=DAT0 A
D0=A
A=DAT0 A
-- D0=A D0 = ->tempenv1
C=DAT0 A
?C=0 A
RTNYES CS: Font not found
A=A+C A
B=A A B[A] = ->nextenv
- D0=D0+ 10 Skip to next LAM name address
A=B A A[A] = ->nextenv
CD0EX C[A] = ->current ptr
?C>=A A If searched this env then switch
GOYES -- to the next one
CD0EX
A=DAT0 A A[A] = ->LAM
AD0EX
D0=D0+ 5
C=DAT0 12 C[W] = LAM start
D0=A
?C#D W
GOYES - Loop until match or next env
D0=D0+ 5 Skip to address part
A=DAT0 A A[A] = ->FNT
A=A+CON A,10 A[A] = ->FNT body
RTNCC CC: Found font
**********************************************************************
->AGrobEnd
**********************************************************************
RPL
