%include "i:maths.inc"
%begin 
%constinteger gbase=16_00d00000
@gbase+16_4000 %short exe
@gbase+16_e020 %integer exeptr
@gbase+16_e024 %integer codeptr
@16_00d10000 %byteinteger rcol=0
@16_00d10001  %byteinteger gcol=0
@16_00d10002  %byteinteger bcol=0
%short complete
%constinteger initial=0,select=1,toggle=2,objstretch=3,objcopy=4,wait=5
%constinteger magic=5000,last=-1,lambda=8,xmin=0,xmax=767,ymin=0,ymax=511
%constbyte fontc=0,inkc=1,planec=2,clipc=3,movec=6
%constbyte boxc=8,asciic=10,linec=12,templatec=13,pixelmapc=14,nullc=15
%constbyte lflag=1,jflag=2,cflag=4,pflag=8,yflag=16,xflag=32
%constbyte movefl=7,inkfl=6,boxfl=5,asciifl=5,nullfl=1,planefl=6,linefl=5
%constbyte rplane=1,gplane=2,bplane=4,spplane=8
%recordformat cmapf(%byte r,g,b,sp)
%recordformat movef(%byte code,flags,%short dx,dy,%integer sub,jmp)
%recordformat inkf(%byte code,flags,%short colour,%integer sub,jmp)
%recordformat boxf(%byte code,flags,%short sx,sy,%integer jmp)
%recordformat asciif(%byte code,flags,%integer sptr,jmp)
%recordformat nullf(%byte code,flags)
%recordformat planef(%byte code,flags,%short mask,%integer sub,jmp)
%recordformat linef(%byte code,flags,%short xsize,ysize,%integer jmp)
@16_d10000 %record(cmapf)%array cmap(0:15)
@16_7fff0 %short mousex=0
@16_7fff2 %short mousey=0
@16_7fff4 %byte  mouseb
%constinteger etp1=0,etp2=1,etd1=2,etd2=3
%integer prevdx,prevdy,dx,dy,newstate,prevstate
%integer x1, y1, x2, y2, x3, y3
%switch state(initial:wait)
%short originalx,originaly


%integerfn new(%integer len)
%constinteger heapl=5000
%owninteger heapp=0
%ownshortarray heap(0:heapl)
%integer i
  i=heapp
  heapp=heapp+len
  %if heapp>heapl %then print string("heap exhausted") %and %stop
  %result=addr(heap(i))
%end

%integerfn abs(%integer value)
  %if value < 0 %then value=-value
%result=value
%end

%external %routine %spec mon(%integer ad,ind)

%routine null(%record(nullf)%name node)
  node_code=nullc
  node_flags=lflag
%end

%routine start
%integer i
%record(nullf) null0
  null(null0)
  exeptr=addr(null0)
  exe=0
  %for i=1,1,10000 %cycle ; %repeat
%end

%routine ascii(%record(asciif)%name node,%string(*)%name text,%integer jmp)
%integer a
  node_code=asciic
  {align text on half-word}
  a=addr(text)
  %if a&1#0 %then node_sptr=a+1 %else text=" ".text %and node_sptr=a+2
  %if jmp=last %then node_flags=pflag!lflag %else %c
    node_flags=pflag!jflag %and node_jmp=jmp
%end

%routine box(%record(boxf)%name node,%short sx,sy,%integer jmp)
  node_code=boxc
  node_sx=sx
  node_sy=sy
  %if jmp=last %then node_flags=lflag %else node_flags=jflag %and node_jmp=jmp
%end

%routine ink(%record(inkf)%name node,%short colour,%integer sub,jmp)
  node_code=inkc
  node_colour=colour
  node_sub=sub
  %if jmp=last %then node_flags=lflag %else node_flags=jflag %and node_jmp=jmp
%end

%routine move(%record(movef)%name node,%byte flags,%short dx,dy,
  %integer sub,jmp)
  node_code=movec
  node_dx=dx
  node_dy=dy
  node_sub=sub
  node_flags=flags
  %if jmp=last %then node_flags=node_flags!lflag %else %c
    node_flags=node_flags!jflag %and node_jmp=jmp
%end
    
%routine plane( %record(planef)%name node,%short mask,%integer sub,jmp)
  node_code = planec
  node_mask = mask
  node_sub = sub
  %if jmp=last %then node_flags=lflag %else node_flags=jflag %and node_jmp=jmp
%end

%routine line(%record(linef)%name node,%short xsize,ysize,%integer jmp)
  node_code=linec
  node_xsize=xsize
  node_ysize=ysize
  %if jmp=last %then node_flags=lflag %else node_flags=jflag %and node_jmp=jmp
%end
 
%routine set cmap
%integer i
  %for i=0,1,15 %cycle
    cmap(i)=0
    %if i&1#0 %then cmap(i)_r=15
    %if i&2#0 %then cmap(i)_g=15
    %if i&4#0 %then cmap(i)_b=15
  %repeat
    cmap(3)_r=9;cmap(3)_g=9;cmap(3)_b=0
    cmap(8)_r=15;cmap(8)_g=15;cmap(8)_b=0
    cmap(12)_r=15;cmap(12)_g=15;cmap(12)_b=0
    cmap(11)_r=15;cmap(11)_g=15;cmap(11)_b=15
    cmap(10)_r=15;cmap(10)_g=15;cmap(10)_b=0
%end

       { *********       MAIN PROGRAM       **********}

   %shortinteger dummyx,dummyy
   %real rxb, ryb, rxe, rye, angle, aangle, rtempa, rtempb, rtempc, rtempd
   %integer tempa, tempb, tempc, tempd, tempe, tempf, tempg, temph, i, ii
   %real rcx, rcy, r
   %integer  xb, yb, xe, ye, xm, ym, cx, cy, sx, sy, iangle
   %record(movef) %name  pos1, pos2, pos3, root, newmove, oldmove, lastmove
   %record(movef) %name  headbrnt, midnode
   %record(inkf) %name  ink1, ink2, ink3, ink4, newink, oldink, lastink
   %record(planef) %name  plane1, plane2, plane3, plane4, newplane, oldplane
   %record(planef) %name  lastplane
   %record(boxf) %name  box1, box2, box3, box4, box5, box6, box7, box8, box9
   %record(boxf) %name  newbox, oldbox, lastbox
   %record(linef) %name  l1, l2, l3, l4, l5, l6, l7, l8, l9, l10
   %record(linef) %name  neewline, oldline, lastline
   %record(asciif) %name asc1, asc2, asc3, asc4, oldasc, lastasc
   %string(20) %name nsa20, nsb20, nsc20, nsd20, nse20,  nsf20, nsg20
   %string(20) sa20, sb20, sc20, sd20, se20, sf20, sg20
   %integer ia, ib, ic, id, ie, ig, if, ih, ik

   %routine linkln(%record(linef) %name node, %short sx, sy)
   neewline==record(new(linefl))
   line(neewline, sx, sy, last)
   lastline_flags=jflag
   lastline_jmp=addr(neewline)
   lastline==neewline
   %end

  {a routine to move the location of a subpicture}
   %routine mvsubp(%integer movex, movey, nink, nplane)
   newmove==record(new(movefl))
   newink==record(new(inkfl))
   newplane==record(new(planefl))
   move(newmove,lflag,movex,movey,addr(newplane),last)
   lastmove_flags=jflag
   lastmove_jmp=addr(newmove)
   lastmove==newmove
   plane(newplane,nplane,addr(newink),last)
   lastplane==newplane
   ink(newink,nink,addr(neewline),last)
   lastink==newink
   %end

set cmap
start
 
 
   {set up a root record and its branch}
   root==record(new(movefl))
   ink1==record(new(inkfl))
   plane1==record(new(planefl))
   box1==record(new(boxfl))
   box2==record(new(boxfl))

   move(root,xflag!yflag,0,0,addr(box2),last)
   ink(ink1,1,addr(root),last)
   plane(plane1,1,addr(ink1),last)
   box(box1,5,5,last)
   box(box2,10,10,addr(box1))

   {memorizinrg the last branch of tree data}
   lastmove==root
   lastink==ink1
   lastplane==plane1
   lastbox==box1

   {link some records onto the tree dynamically}
   newbox==record(new(boxfl))
   box(newbox,10,20,last)
   lastbox_flags=jflag
   lastbox_jmp=addr(newbox)
   lastbox==newbox

   asc1==record(new(asciif))
   asc2==record(new(asciif))
   asc3==record(new(asciif))
   asc4==record(new(asciif))
   sa20<-"frist ascii display"
   nsa20==sa20
   ascii(asc1,nsa20,last)
   lastbox_flags=jflag
   lastbox_jmp=addr(asc1)
   lastasc==asc1

   newmove==record(new(movef))
   newplane==record(new(planef))
   newink==record(new(inkf))
   newbox==record(new(boxf))
   move(newmove, lflag, 150, 150, addr(newplane), last)
   plane(newplane, 3, addr(newink), last)
   ink(newink, 3, addr(newbox), last)
   box(newbox, 30, 30, last)
   lastasc_flags=pflag!jflag
   lastasc_jmp=addr(newmove)
{   mon(addr(root),0)   }

   {painting the circle}
   x1=mousex//4; y1=mousey//4
   codeptr=addr(complete)
   exeptr=addr(plane1)
   complete=0
   exe=0
   %cycle; %repeat %until complete#0
   x2=mousex//4; y2=mousey//4
   x3=x2-x1; y3=y2-y1
   headbrnt_dx=headbrnt_dx+x3
   headbrnt_dy=headbrnt_dy+y3
%endprogram
