{**********************************************************************}
{*                          APMTEL Client                             *}
{*                  Andrew Ness  1988  CS4 project                    *}
{*               Modded version - see mod list below                  *}
{*                                                                    *}
{*                    Version 1.2 20 Jun 1988                         *}
{**********************************************************************}

! Control sub-module
!
!
!        USER INTERFACE TO THE APMTEL SERVER ON FILESTORE D
!
! History:
!
! 20/2/88      Initial naive unfriendly version written to test SERVER
! 22/2/88      Re-write and re-structure of the code for ease of maintainance
!  3/3/88      Inclusion of REGION untility to allow access to caching mechanism
!  3/3/88      Addition of cache structure access thru insert page to place a
!              file into a cache database 
!              So far this cache is write-only, but I am working on the code to
!              allow reading the cache
!  8/3/88      The cache is now read-write
! 10/5/88      Inclusion of Channel 5 - EUCSD pages
! 16/5/88      cache only indication if server is not running
! 17/5/88      Addition of design module 
! 17/5/88      Addition of termlib control for user interface
!

%option "-low-nons"
%include "APMTEL:ins_pg3.inc"
%include "inc:fs.imp"
%include "inc:fsutil.imp"
%include "inc:util.imp"
%include "inc:vtlib.imp"
%include "files.inc"

%include "level1:graphinc.imp"

%constinteger MaxR=23, MaxC=39,
escape     = 27,
keypad     = 79,
cursors    = 91,

uparrow    = 65,
downarrow  = 66,
rightarrow = 67,
leftarrow  = 68,
home       = 72,

enter      = 77,
pf1        = 80,
pf2        = 81,
pf3        = 82,
pf4        = 83,
padcomma   = 108,
padminus   = 109,
paddot     = 110,
pad0       = 112,   pad1=113, pad7=119, pad8=120, pad9=121,
delete     = 127

%externalroutinespec show comments

%constbyte  default mode = 0, 
            graphics mode = 1, 
            held mode = 2,
            double height mask = 4, 
            separated graphics mask = 8,
            conceal = 16

%constinteger hold graphics = 30,
              release graphics = 31,
              new background   = 29,
              black background = 28,
              double height    = 13,
              normal height    = 12,
              contiguous graphics = 25,
              separated graphics  = 26

%constinteger text = 0,
              graphics = 1,
              sep graphics = 2,
              double text = 3,
              double graphics = 4,
              double sep graphics = 5

%begin

%integer font w, font h

%ownbytearray page(0:31,0:MaxC)= ' '(*)
%ownbytearray dh(0:MaxR)

%ownintegerarray font store (0 : 5) = 0(*)
%owninteger current font=text
%ownintegerarray virscreen(0:31, 0:39) = 0(*)

%constinteger  server station = 16_35, { Filestore D station number
               magic number = 16,      { The magic number of the APMTEL server
               my port= 21,            { The local port used
               buf size = 520,         { Maximum size of the ether packet
               true = 1,
               false = 0

%integer      server port,
              n,
              c,
              graphics flag,
              cache only
%byte         comm
%integer      pagestore,       {100 * bytearray    page(0:31,0:39) }
%integer      i,
              j, 
              command, param,
              channel
%string (255) filename

%constinteger title row=0, menu row=2, menu col=40, error row=15,
   comment row=17, prompt row=menu row+8, com row=20,divider col=39
!spaceline is <divider col> spaces and a bar.
%conststring (40) spaceline = "|                                       "

%routine line(%integer row)
   vt at(row,menu col);
   printstring(spaceline);
   vt at(row, menu col)
%end

%routine print at line(%integer row, %string (255) text)
  %string (255) thistext
  %while text -> thistext.(snl).text %cycle
     vt at(row, menu col); printsymbol('|')
     printstring(thistext); spaces(40-length(thistext))
     row=row+1
  %repeat
  vt at(row, menu col); printsymbol('|')
  printstring(text); spaces(40-length(text))
%end

%routine title line(%string (255) text)
  line(title row); printstring(text)
%end

%routine flag error(%string (255) text)
  print at line(error row, text)
%end

%routine flag comment 2(%string (255) text)
  print at line(comment row+1, text)
%end

%routine flag comment(%string (255) text)
  print at line(comment row, text)
%end

%routine show prompt(%string (255) text)
  print at line(prompt row, text)
  vt at(prompt row+1, menu col)
%end

%predicate pending read(%integer port)
%integer bit
   bit=1<<port
   %true %if dtx & bit # 0
   %false
%end


%integerfn get ether(%byte port, %bytearrayname buf(0:*), %integer timeout)
%integer t, bytes
   bytes = 0
   t = cputime
   %cycle
      %if pending read(port) %then bytes = ether read(port,buf(0),BUF SIZE)
   %repeatuntil cputime-t > timeout*1000 %or bytes#0
   %return bytes
%end

%integerfn server handshake(%string (255) command, %integer timeout,
%bytearrayname response(0:*), %integername len)
   %integer t
   ether write(my port,charno(command,1),length(command))
   t = cputime
   %cycle
      %if pending read(my port) %then %c
         len = ether read(my port,response(0),BUF SIZE) %and %result=0
      %result=-1 %if cputime-t > timeout*1000
!!      %result=1 %if testsymbol=' '
   %repeat
%end

%predicate start talking
   %integer rc
   %string (255) command
   %bytearray buffer(0:1279)
   ether close(my port)                   {Make sure local port is closed
   ether open(my port, server station<<8) {Open connection to the SERVER
   command = tostring(magic number)
   rc=server handshake(command, 5, buffer, n); !"Hello server"
!
!If the number of bytes rxd is 0, then the filestore is not up or is busy....
!so tell the user to try again later   
!
   clear frame
   %if rc#0 %start
      flag error("Server not responding - cache only".snl. %c
      "Retry by attempting to force a download (menu option 2)")
!      ether close(my port)
      %false
   %finish
!
!Now, if the remote port number is less than 1, then the server is not running
!on the filestore
!
   server port = buffer(0) - '0'
   %if server port <1 %start
      flag error("Server not running - cache only".snl. %c
      "Retry by attempting to force a download (menu option 2)")
!      ether close(my port)
      %false
   %finish
   flag comment("Hi - APMTEL SERVER Connected")
   ether close(my port)
   ether open(my port, server station << 8 ! server port)
   rc=server handshake("A".current user, 5, buffer, n)
   cache only = false
   %true
%end


%bytefn to upper(%byte c)
%if 'a' <= c <= 'z' %thenreturn c-'a'+'A' %elsereturn c
%end


!Routine to take teletext page/subpage from header and convert to integer.
%integerfn txstoi(%integer packet)
   %constinteger hi=0, lo=1
   %integerfn nib(%integer offset,hilo)
      %integer n
      n = byteinteger(packet+offset)
      %if hilo=hi %then n=n>>4
      %result=n&15
   %end
   %result = %c
   (((((nib(5,lo)*10+nib(0,hi))*10+nib(0,lo))*10+nib(1,hi))*10+%c
   nib(1,lo))*10+nib(2,hi))*10+nib(2,lo)
%end

%integerfn pg(%integer channel, %integer page)
   !Takes page specified as an integer channel plus 
   !page number (we hope as a decimal number, 100<=n<=999) and turns it into
   !a 16-bit integer, top 4 bits channel, bottom 12 page number as BCD.
   %integer h,t,d

!! write(page,3); write(channel,3)
   h = page//100
   page = page - h*100
   t = page//10
   d = page - t*10
   channel = channel & 16_0F
!! write(channel,3); write(h,3); write(t,3); write(d,3); newline
   %result=((channel<<4+h)<<4+t)<<4+d
%end

%conststring (255) %array getfail(-1:4) = %c
   {-1}"Server <-> Teletext receiver timeout",
   {0} "OK",
   {1} "Request cancelled",
   {2} "Server died while transmitting on ether",
   {3} "Server failed to transmit page to ether",
   {4} "Software error"

%routine move(%integer bytes, %bytename from, to)
   !Move BYTES bytes from FROM to TO. Pinched from IE.
   !If addr(FROM) < addr(TO) do the move from the top down to allow overlap
   %return %if Bytes = 0 %or  From == To

   %if Addr (To) < Addr (From) %start
      *Subq.l #1, d0
   f loop:
      *move.b (a0)+, (a1)+
      *dbra   d0, f loop
   %else
      *add.l  d0, a0
      *add.l  d0, a1
      *subq.l #1, d0
   b loop:
      *move.b -(a0), -(a1)
      *dbra   d0, b loop
   %finish
%end

%ownstring(40) spaces40 = "                                        "

%integerfn get subpage from server(%integer param, to, %integername status)
   %string (255) command
   %bytearray buffer(0:1279), coda(0:511)
   %integer rc,rc2,n,i

   %routine unpack teletext(%bytearrayname buffer, to(0:1279))
      %integer row, p, mag,i
      %bytearray check(0:31)

      !Note:  Rows 26, 28 and 29 are not transmitted.   There may be up to 4
      !row 27s.  I put the first row 27 in row 27 and any others in rows
      !26 then 28 and 29.
      !Unused rows have MAG and ROW set to 0.

      p=0
      %for i=0,1,31 %cycle; check(i)=0; %repeat
      %for i=0,1,23 %cycle ;!Max. of 24 42-byte rows in 1024 chars
         mag=buffer(p); row=buffer(p+1)
         %if mag#0 %start
            %if row=27 %start
               !Clumsy
               !does it in received order without dehamming the subrow no.
               row=26 %if check(27)#0
               row=28 %if check(26)#0
               row=29 %if check(28)#0
            %finish
            move(40, buffer(p+2), to(row*40))
            check(row)=1
         %finish
         p=p+42
      %repeat

      !Fill in empty rows - assumed to contain spaces
      %for row=1,1,31 %cycle
         %if check(row)=0 %start
            move(40, charno(spaces40, 1), to(row*40))
         %finish
      %repeat

      to(5) = buffer(0) ;!Save the magazine in an unused header byte
      status = buffer(5)<<8+(buffer(6)&255)
 
   %end

   command = "B".itos(param,-1)
   rc=server handshake(command, 200, buffer, n)
   %if rc=0 %start ;!Success
      %if n=512 %start
         !Expect the 2nd frame fragment
         n= get ether (my port,array(addr(buffer(512))), 6)
         %if n=512 %start
            !Then the status message
            n=get ether(my port,coda,512)
            !Now unpack the frame
            unpack teletext(buffer, array(to))
         %else
            !Server died between sending blocks 1 and 2.
            %result=2
         %finish
      %else
         %result=3
      %finish
   %else
     %if rc>0 %start
!!     rc2=server handshake("E",5,array(to),n)
       !Note possibility for confusion if the cancel crosses the pages
       !coming back.  Sort this later.
     %finish
   %finish
   %result=rc
%end

%integerfn mod10(%integer no); %result = no - (no//10)*10; %end
%integerfn mod100(%integer no); %result = no - (no//100)*100; %end

%constinteger %c
   erase page       = 16_08, {byte 4}
   newsflash        = 16_10, {byte 4}
   subtitle         = 16_20, {byte 4}
   suppress header  = 16_01, {byte 5}
   update indicator = 16_02, {byte 5}
   out of sequence  = 16_04, {byte 5}
   inhibit display  = 16_08, {byte 5}
   serial magazine  = 16_10  {byte 5}

%string (15) %fn statusbits(%integer status)
   !Returns the frame status bits as a string
   %byte c4,c5
   %string (15) s
   c4 = status>>8; c5 = status & 16_FF
   s=""
   s=s."e" %if c4 & erase page # 0
   s=s."n" %if c4 & newsflash # 0
   s=s."s" %if c4 & subtitle # 0
   s=s."h" %if c5 & suppress header # 0
   s=s."u" %if c5 & update indicator # 0
   s=s."o" %if c5 & out of sequence # 0
   s=s."i" %if c5 & inhibit display # 0
   s=s."m" %if c5 & serial magazine # 0
   s=s."?" %if c4 & (\(erase page ! newsflash ! subtitle)) # 0 %or %c
   c5 & (\(suppress header ! update indicator ! out of sequence ! %c
   inhibit display ! serial magazine)) # 0
   s="[".s."]" %unless s=""
   %result=s
%end

%predicate alpha colour(%byte ch)
   %trueif 1<= ch&127 <= 7
   %false
%end

%predicate graphics colour(%byte ch)
   %trueif 17 <= ch&127 <= 23
   %false
%end

%predicate alpha control(%byte ch)
   %true %if ch&127=release graphics
   %false
%end

%predicate graphics control(%byte ch)
   %true %if ch&127=hold graphics %or %c
             ch&127=contiguous graphics %or %c
             ch&127=separated graphics
   %false
%end

%predicate graphics present
   %on 0 %start
      %false
   %finish
   plot(0,0)
   %true
%end

%routine print row (%byte row, %integer col, %bytearrayname page (0:31,0:MaxC))
%byte ch, background colour, last graphics char, mode, display colour
%integer column, temp font
%on 0 %start; %return; %finish

   %routine select font(%integer font no)
      current font = font no
      font(font store(current font))
   %end

   %routine process control(%bytename fch)
      ! set alpha colour
      %byte ch

      ch=fch&127
      %if alpha colour(ch) %start
         %if mode & double height mask # 0 %then select font(double text) %c
         %else select font(text)
         mode = mode & \graphics mode
         display colour = ch
         colour (ch)
         ch = ' '
         last graphics char = ' '

      %elseif graphics colour(ch)
         ! set graphics colour and font
         display colour = ch - 16
         colour(display colour)
         %if mode & held mode # 0 %then ch = last graphics char %else ch=' '

         %if mode & separated graphics mask # 0 %start
            ! select separated graphics
            %if mode & double height mask # 0 %start
               select font(double sep graphics)
            %else
               select font(sep graphics)
            %finish
         %else
            ! select contiguous graphics font
            %if mode & double height mask # 0 %start
               select font(double graphics)
            %else
               select font(graphics)
            %finish
         %finish
         mode = mode! graphics mode

      %elseif ch = contiguous graphics
         mode = mode & \separated graphics mask
         ! change graphics font type to contiguous
         %if mode & double height mask # 0 %start
            select font(double graphics)
         %else
            select font(graphics)
         %finish
         ch = last graphics char

      %elseif ch = separated graphics
         ! change graphics font type to contiguous
         mode = mode! separated graphics mask
         %if mode & double height mask # 0 %start
            select font(double sep graphics)
         %else
            select font(sep graphics)
         %finish
         ch = last graphics char

      %elseif ch = hold graphics
         ! font (graphics font) 
         mode = mode! held mode
         ch = last graphics char

      %elseif ch = release graphics
         mode = mode & \held mode
         ch = last graphics char

      %elseif ch = new background
         background colour = display colour
         ch = last graphics char

      %elseif ch = black background
         background colour = black
         ch = last graphics char

      %elseif ch = double height
         select font(current font+3) %if current font <= 2
         !this is either the double-graphics command or the masked-out characters
         !following it.  
         %if fch=141 %then ch=141 %else ch=last graphics char
         mode = mode! double height mask

      %elseif ch = normal height
         select font(current font-3) %if current font >= 3
         ch = last graphics char
         mode = mode & \double height mask

      %else
         ch = last graphics char
      %finish
      fch=ch
   %end
   
   %routine an show sym(%integer fc)
      %integer desc, descend, c
      c=fc&127
      desc = (((current font<<8)+background colour)<<8+display colour)<<8+fc
      %if desc # virscreen(row,column) %start
         %unless c = 127 %and mode & graphics mode # 1 %start
            colour (background colour)
            !Do a big background for double-height fonts.
            %if  dh(row)#0 %then descend=font h %else descend=0
            fill(column*font w, 476-row*font h-descend,
            (column+1)*font w-1, 476-(row-1)*font h-1)
            colour(display colour)
         %finish

         %if current font<=2 %then descend=0 ;!small chars on a double-ht line
         text at(column*font w, 476-row*font h-descend) %and show symbol(c) %c
         %unless c = ' ' %or c=13
         virscreen(row,column) = desc
      %finish
   %end

   %return %if graphics flag=0
   select font(text)
   last graphics char = ' ';
   mode = default mode; display colour = white
   background colour = black
   colour (display colour)
   %for column = 0, 1, MaxC %cycle
      ch = page (row, column)
      %if ch & 16_20#0 %and mode&held mode#0 %then last graphics char=ch&127
      %if ch&127 < 32 %then process control(ch) ;!Leaves ch= ' ' or last graphics char
      an show sym (ch)
   %repeat
%end

%routine print wy row (%byte row, %integer C column, %bytearrayname page(0:31,0:39))
   %byte mode, last graphics char, display colour, background colour
   %integer column, c, current mode
   %constinteger normal=0, underline=8, dim=1, graphic=16
   %byte ch,ttmode

   %routine change mode
      set shade(mode)
      current mode=mode
   %end

   vt at(row, 0)
   set shade(normal)
   %for column = 0, 1, MaxC %cycle
      ch = page(row,column)
      %if graphics colour(ch) %or graphics control(ch) %start
        ttmode=graphic
      %elseif alpha colour(ch) %or alpha control(ch)
        ttmode=normal
      %finish
      mode=normal
      %if ch<32 %start
         ch=32
      %elseif ch<64
         mode=intense %if ttmode=graphic
      %elseif ch<96
      %elseif ch<128
         mode=intense %if ttmode=graphic
      %elseif ch<160
        ch=ch-64; mode=intense
      %elseif ch<192
        ch=ch&127
        mode=intense %if ttmode=graphic
      %elseif ch<224
        ch=ch&127
      %else
        ch=ch&127
        mode=intense %if ttmode=graphic
      %finish
      %if column = C column %start ;!Flip mode over cursor
        %if mode=intense %then mode=normal %else mode=intense
        change mode
        %if mode=normal %then mode=intense %else mode=normal
      %else
        change mode {%if mode # current mode}
      %finish
      printsymbol(ch)
   %repeat
%end

%integerfn succR(%integer row)
  !Return the number of the next valid row.  This looks after wraparound
  !and blocks access to the lower row of a double-height row
  %if row#MaxR %and dh(row)#0 %start
    row=row+1; row=0 %if row>MaxR
  %finish
  row=row+1; row=0 %if row>MaxR
  %result=row
%end

%integerfn predR(%integer row)
  !Return the number of the previous valid row.  This looks after wraparound
  !and blocks access to the lower row of a double-height row
  row=row-1; row=MaxR %if row<0
  %if row#0 %and dh(row-1)#0 %start
    row=row-1; row=MaxR %if row<0
  %finish
  %result=row
%end

%routine show screen(%integer pg,C row, C column)
   %integer row, column, char pointer, col
   %bytearray page(0:31,0:MaxC)

   %constinteger hi=0, lo=1
   %integerfn nib(%integer offset,hilo)
      %integer n
      n = byteinteger(pg+offset)
      %if hilo=hi %then n=n>>4
      %result=n&15+'0'
   %end ;!of nib

   move(1280, byteinteger(pg), page(0,0))

   page(0,0) = nib(5,lo)
   page(0,1) = nib(0,hi)
   page(0,2) = nib(0,lo)
   page(0,3) = nib(1,hi)
   page(0,4) = nib(1,lo)
   page(0,5) = nib(2,hi)
   page(0,6) = nib(2,lo)
 
   row=0
   %cycle
      %if row=C row %then col = C column %else col = -1
      print wy row (row,col, page); print row(row,col, page)
      row=SuccR(row)
   %repeatuntil row=0
%end ;!of show screen

%routine spot dh(%integer base)
  %integer row, column,p
  %for row=0,1,MaxR %cycle
    dh(row)=0
  %repeat
  p=base
  %for row=0,1,MaxR %cycle
    %for column=0,1,MaxC %cycle
      dh(row)=dh(row)+1 %if byteinteger(p)&127=double height
      p=p+1
    %repeat
  %repeat
%end

%integerfn get page from server(%integer page, base, %integername subpages)
   %integer rc, full pageno, f, firstf, maxsub, i, latestf, to, status
   firstf=-1; f=0; subpages=-1; maxsub=-1

   !Once the subpages have wrapped round, we know we have a complete page
   !and how big it is.
   subpages=0
   %cycle
      to = base + f * 1280
      rc=get subpage from server(page, to, status)
      %result=rc %if rc#0
      full pageno = txstoi(to)
      spot dh(to)
      show screen(to,-1,-1)
      latestf=f;  f = mod100(full pageno) ;!the subpage number

      %if firstf<0 %start;!start point in subpage cycle
         firstf=f 
         !Page is in subpage-0 slot.  Copy the page to the correct place
         move(1280,byteinteger(to), byteinteger(base+(f-1)*1280)) %if f>1
      %finish

      %if f=0 %start; !Only subpage
         flag comment("   Page ".itos(full pageno,-1)." ".status bits(status))
         subpages=1
         %result=0
      %elseif f=latestf ;!subpages are looping
         flag comment("Subpage ".itos(full pageno,-1)." looping")
         subpages=1
         %result=0
      %else
         flag comment("Subpage ".itos(full pageno,-1)." ".status bits(status)." arrived") 
      %finish

      %if f<latestf %start
         !We've turned the corner: Maxsub is the top subpage number.
         maxsub=latestf
         move(1280, byteinteger(to), byteinteger(base + (f-1)*1280))
         %if firstf=1 %then subpages=maxsub %and %result=0
         !special case where firstf=1: we've just wrapped round
      %finish

      %if f+1=firstf %then subpages=maxsub %and %result=0
      !about to complete the cycle
   %repeat
   %result=4
%end

%routine browse(%integer base, lo, hi)
   %integer c, offset, minbase, maxbase
   %routine r; %cycle; c=testsymbol; %repeatuntil c>=0; %end
   flag comment("Use up and down arrows to scan page.".snl. %c
   "Press <return> to exit")
   minbase=lo*1280; maxbase=hi*1280
   offset=minbase
   %cycle; %repeatuntil testsymbol<0
   %cycle
      spot dh(base+offset)
      show screen(base+offset,-1,-1)
      %cycle
         r
         %if c=27 %start
            r
            %if c=91 %start
               r
               %if c=65 %start ;!Up
                  %if offset>minbase %then offset=offset-1280 %else offset=maxbase
               %elseif c=66 ;!Down
                  %if offset<maxbase %then offset=offset+1280 %else offset=minbase
               %finish
               %exit
            %finish
         %elseif c=10
            %exit
         %finish
      %repeat
      %exit %if c=10
   %repeat
%end

%routine carousel(%integer page)
   %integer rc, full pageno, f, firstf, subpages, maxsub, i
   flag comment("Press a key to exit".snl. %c
   "This may take some time so be patient")

   %cycle; %repeatuntil testsymbol=-1
   %cycle
      %exit %if testsymbol>=0
      rc=get page from server(page, pagestore, subpages)
      %if rc=0 %and subpages#0 %start
!!         %if subpages>1 %start
!!            show prompt("browse?")
!!            %cycle
!!              f=testsymbol
!!              f='N' %if f=13 %or f=10 %or f='n'
!!              f='Y' %if f='y'
!!            %repeatuntil f='Y' %or f='N'
!!            %if f='Y' %start
!!               browse(pagestore, 0, subpages-1)
!!            %finish
      %else
         flag error("Page request failed - ".getfail(rc).snl. %c
         "Press <space> to continue")
         %cycle; %repeatuntil testsymbol=' '
      %finish
   %repeat
%end

%owninteger subpages=0

%routine design

%integer font w, font h,
         m x, m y,
         char x, char y,
         old m x, old m y

%constinteger  cursor plane = 8,  rest = 7,
               TRUE = 1, FALSE = 0
   
%routine printline(%string (255) s)
   printstring(s); newline
%end ;!of printline in design

%routine setup screens
  set frame(0,24,0,80)
  clear frame
  %if graphics flag = true %start
    clear
    Offset (0,0)
    enable(rest)
  %finish
  set terminal mode(no page)
%end ;!of setup screens in design

! draw cursor:      draw a box round the character box containing (x,y)
!                   i.e. snap the cursor onto the character grid
%routine draw cursor(%integer row,column,h)
  %integer x,y
  %on 0 %start; %return; %finish
  x = column*font w
  y = 476-row*font h - (h-1)*font h
  enable(cursor plane)
  colour(32767)
  hline (x,x+font w,y)
  hline (x,x+font w,y+font h*h)
  vline (x,y,y+font h*h)
  vline (x+font w,y,y+font h*h)
  enable(rest)
%end ;!of - in design

! undraw cursor:     erases the cursor from the screen
%routine undraw cursor(%integer row,column,h)
  %integer x,y
  %on 0 %start; %return; %finish
  x = column*font w
  y = 476-row*font h - (h-1)*font h
  enable(cursor plane)
  colour(0)
  hline(x,x+font w,y)
  hline(x,x+font w,y+font h*h)
  vline(x,y,y+font h*h)
  vline(x+font w,y,y+font h*h)
  enable(rest)
%end ;!of - in design

%integerfn get m position
!
! Repeats a loop polling the m position until a button is pressed
!
%integer temp buttons, x off, y off, t
   set frame(15,5,0,40)
   clear frame
   print string("PLEASE SELECT MENU OPTION :-")
   %cycle
      x off = rel mouse x
      y off = rel mouse y
      m x = m x + x off 
      m y = m y + y off 
      %if mx > 39 * fontw %then mx = 39*fontw %elseif mx < 0 %then mx = 0
      %if my > 23 * fonth %then my = 23*fonth %elseif my < 0 %then my = 0
      %if m x # old m x %or m y#old m y %start
         undraw cursor(old m x, old m y,0)
         old m x = m x; old m y=m y
         draw cursor(old m x, old m y,0)
         char x = m x // font w 
         char y = m y // font h 
         !write(23-char y,5);write(char x,5);newline
      %finish
      temp buttons = test symbol - '0'
   %repeatuntil 1<=temp buttons <= 8
   newline
   %return temp buttons
%end ;!of - in design

! setup designer:    intialise the variables and framestore for use by the
!                    designer
%routine setup designer
   setup screens
   m x = 320
   m y = 256
   old m x = 0 ; old m y = 0
   font w = max font width
   font h = font height
%end ;!of - in design


%routine load file(%string (255) name,%bytearrayname p(0:31,0:MaxC))
%label abort
%integer i,j,t
   %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
       flag error("Sorry cannot load ".name." because ".event_message)
       ->abort
   %finish
   open input(1,name)
   select input(1)
   %for i=0,1,MaxR %cycle
      %for j=0,1,MaxC %cycle
         read symbol(t)
         p(i,j) = t                              {NEEDED FOR VTLIB
      %repeat
   %repeat
   spot dh(addr(p(0,0)))
   show screen(addr(p(0,0)), 0,0)
abort:
   close input
   select input(0)
%end ;!of - in design

%routine save file(%string (255) name)
%label abort
%integer i,j
    %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
       flag error("Sorry cannot do that because ".event_message)
       -> abort
    %finish
    open output(1,name)
    select output(1)
    %for i=0,1,MaxR %cycle
       %for j=0,1,MaxC %cycle
       printsymbol(page(i,j))
       %repeat
    %repeat
abort:
    close output
    select output(0)
%end ;!of - in design

!!!%integerfn pg(%integer channel, %integer page)
!!!   !Takes page specified as an integer channel plus 
!!!   !page number (we hope as a decimal number, 100<=n<=999) and turns it into
!!!   !a 16-bit integer, top 4 bits channel, bottom 12 page number as BCD.
!!!
!!!   %result=(page&16_FFF) ! (channel&16_0F)<<12
!!!%end ;!of - in design

%routine save to db(%integer location, %string(255) comments)
   %integer page id
   page id = pg(5, location)
   !Forget comments   
   write cached page(page id, addr(page(0,0)), 1)
%end ;!of - in design

%routine load from db(%integer channel, location)
   %integer page id, subpages
   page id = pg(channel, location)
   read cached page(page id, addr(page(0,0)), subpages)
   %if subpages#0 %start
      spot dh(addr(page(0,0)))
      show screen(addr(page(0,0)),-1,-1)
   %else
      flag error("Page not present")
   %finish
%end ;!of - in design

%routine do design
  %constinteger norm=0
  %integer i,j,mode,control,channel,row,column,c,finished
  %string (255) line

%integerfn C mode(%integer row, col)
  %constinteger normal=0, underline=8, dim=1
  %byte ch, mode
  ch = page(row, col)
      %if row=0 %start
         mode=intense
      %elseif ch<32
         mode=normal
      %elseif 32<=ch<=127
         mode = normal
      %elseif 129<=ch<=135
         mode=normal
      %elseif 156<=ch<=157 ;!New background
         mode=normal
      %elseif 128<=ch<=159
         mode=intense
      %else
         mode=intense
      %finish
  %result = mode
%end ;!of - in do design in design

%routine zap cursor
  %integer h
  set shade(C mode(row, column))
  vt at(row,column); printsymbol(page(row,column))
  %if dh(row)=0 %then h=1 %else h=2
  undraw cursor(row, column, h)
%end ;!of - in do design in design

%routine paint cursor
  %integer mode,h
  %constinteger normal=0, underline=8, dim=1
  mode = C mode(row, column)
  vt at(row, column)
  %if mode = normal %then set shade(intense) %else set shade(normal)
  print symbol(page(row,column))
  %if dh(row)=0 %then h=1 %else h=2
  draw cursor(row, column, h)
%end ;!of - in do design in design

%routine C right
  zap cursor
  column = column + 1
  %if column > MaxC %start { Wrapround
    column = 0 ; row = succR(row)
  %finish
  paint cursor
%end ;!of - in do design in design

%routine C down
  zap cursor
  row = succR(row)
  paint cursor
%end ;!of - in do design in design

%routine C return
  zap cursor
  row=succR(row); column=0
  paint cursor
%end

%routine C up
  zap cursor
  row = predR(row)
  paint cursor
%end ;!of - in do design in design

%routine C left
  zap cursor
  column = column - 1
  %if column < 0 %start { Wrapround
    column = MaxC ; row = predR(row)
  %finish
  paint cursor
%end ;!of - in do design in design

%routine zap line(%integer row)
  %integer column
  %for column=0,1,MaxC %cycle; page(row,column) = ' '; %repeat
  dh(row)=0
%end

%routine C home
  zap cursor
  row=0; column=0
  paint cursor
%end ;!of - in do design in design

%routine get(%integername c)
   %cycle; c=testsymbol; %repeatuntil c>=0
%end

  %routine add(%byte c)
    %constinteger normal=0
    zap cursor
    %if page(row, column)&127 = double height %start
      %if c&127#double height %then dh(row) = dh(row) - 1
    %else
      %if c&127=double height %then dh(row) = dh(row) + 1
    %finish
    page(row, column) = c
!   paint cursor  {no point - C Right will wipe it again}
    vt at(row, column);
    %if c<=127 %then printsymbol(c) %elsestart
      set shade(intense); printsymbol(c&127+'A'); set shade(normal)
    %finish
!t  flag comment("add ".itos(page(row,column),-1)." ".itos(row,-1)." ".itos(column,-1))
    C right
 %end ;!of add in do design in design

%constintegerarray f(1:12) = 0,31,59,90,120,151,181,212,243,273,304,334
%conststring (3) %array dy(0:6) = "Mon", "Tue", "Wed","Thu", "Fri", "Sat", "Sun"

%string (9) %fn weekday(%string (*) %name date)
   !Returns the day of week of the supplied date. Works for all dates in the
   !format dd/mm/yy, yy assumed to be between 1900 and 1999.
   !White space on front of date is ignored and so is garbage after the date bit.
   %integer day, month, year, i
   i = 1
   i = i + 1 %while charno(date, i) < '0' ;!Skip past leading junk
   !Split date up into day, month, year
   day = stoi(substring(date, i, i+1))
   month = stoi(substring(date, i+3, i+4))
   year = stoi(substring(date, i+6, i+7))
   day = f(month) + day ;!Past months this year + days this month
   day = day + 1 %if year & 3 = 0 %and year # 0 %and month > 2 ;!Leap year correction
   !Complete past years + correction for day-of-week of 1/1/00
   day = day + year * 365 + 6
   day = day + (year-1)>>2 %if year # 0 ;!past leap years
   %result = dy(day - (day//7)*7)
%end

%routine form header(%bytearrayname pg(0:31, 0:MaxC), %integer pageno)
  %integer t
  %string (255) d
  %routine p(%byte val);     pg(0,t) = val; t=t+1;   %end
  %routine ps(%string (63) s)
    %integer i
    %for i=1,1,length(s) %cycle; p(charno(s,i)); %repeat
  %end
  t=0
  d = date
  p(mod100(pageno)//10<<4+mod10(pageno)); p(0); p(0); p(0); p(0); p(pageno//100)
  ps("  EU.CSD ".itos(pageno,3)."  ".weekday(d)." ".d."  ".time)
%end

! Do Design - Main code

%for row=0, 1, MaxR %cycle; zap line(row); %repeat
row=0; column=0
finished = false
form header(page, 500)
show screen(addr(page(0,0)),0,0)
C home
%cycle
  get(c)
  %if c = escape %start
    get(c)
    %if c=cursors %start
      get(c)
      %if c = uparrow %start
        C up

      %elseif c = downarrow
        C down

      %elseif c = leftarrow
        C left

      %elseif c = rightarrow
        C right

      %elseif c = home
        C home

      %finish
    %elseif c=keypad
      get(c)
      %if pad1<=c<=pad7 %start
        add(c-pad0+128)
        mode=norm
        print wy row(row, column, page); print row(row,column, page)
        flag comment2(itos(c,3).itos(page(row,column), 3))

      %elseif c=pad8
        add(128+normal height)
        print wy row (row,column, page); print row(row,column, page)
      %elseif c=pad9 %and row#MaxR %and dh(row+1)=0
        zap line(row+1)
        add(128+double height)
        print wy row (row,column, page); print row(row,column, page)
      %elseif c=pad0
        get(c)
        %if c=escape %start
          get(c)
          %if c=keypad %start
            get(c)
            %if pad1<=c<=pad7 %start
              add(c-pad0+144)
            %elseif c=pad8
              add(128+black background)
            %elseif c=pad9
              add(128+new background)
            %finish
            print wy row(row, column, page); print row(row, column, page)
          %finish
        %finish

      %elseif c=pf1
        show prompt("LOAD file:")
        read line(line)
        %if line#"" %then load file(line,page)

      %elseif c=pf2
        show prompt("SAVE file:")
        read line(line)
        save file(line)

      %elseif c=pf3
        show prompt("LOAD channel:")
        read(channel)
        show prompt("LOAD page id:")
        read(control)
        load from db(channel, control)

      %elseif c=pf4
        show prompt("SAVE id:")
        read(control)
        show prompt("Comment line:")
        read line(line)
        line = current user." <-> ".line
        save to db(control, line)

      %elseif c=padcomma
        zap line(row)
        show screen(addr(page(0,0)),row,column)

      %elseif c=padminus
        %for i=0,1,MaxR %cycle
          zap line(i)
        %repeat
        show screen(addr(page(0,0)),row,column)

      %elseif c=enter
        finished = true
      %finish
    %finish
  %elseif c=13
    C return

  %elseif c=delete
    C left
    add(' ')
    C left
    print wy row(row, column, page); print row(row,column,page)
  %else
    add(c)
    print wy row(row, column, page); print row(row,column,page)
  %finish
  %repeatuntil finished = true
  clear frame
%end ;!of do design in design

%routine show menu
   print at line(0, " 1:alpha red         2:alpha green")
   print at line(1, " 3:alpha yellow      4:alpha blue")
   print at line(2, " 5:alpha magenta     6:alpha cyan")
   ! 1-7 alpha colours: red,green,yellow,blue,magenta,cyan,white
   ! 8: flash, 9: steady, 10,11: unused
   ! 12: normal height, 13: double height
   ! 14,15,16: unused
   ! 17-23 graphic colours: red,green,yellow,blue,magenta,cyan,white
   ! 24: conceal
   ! 25: contig graphics, 26: sep graphics
   ! 27: unused
   ! 28:black background 29:new background
   ! 30:hold graphics    31:release graphics
   print at line(3, " 7:alpha white       8:normal height")
   print at line(4, " 9:double height    01:graphic red")
   print at line(5, "02:graphic green    03:graphic yellow")
   print at line(6, "04:graphic blue     05:graphic magenta")
   print at line(7, "06:graphic cyan     07:graphic white")
   print at line(8, "08:black background 09:new background")
   print at line(9, "25:contig graphics  26:sep graphic")
   print at line(10, "30:hold graphics    31:release graphics")
   print at line(11, "")
   print at line(12, "CONTROL CODES")
   print at line(13, "pf2: Save page to file")
   print at line(14, "pf1: Load page from file")
   print at line(15, "pf4: Save page to db")
   print at line(16, "pf3: Load page from db")
   print at line(17, " - : Clear page")
   print at line(18, " , : Clear line")
   print at line(19, "enter: quit")
   print at line(20, "")
   print at line(21, "")
   print at line(22, "")
   print at line(23, "")
%end ;!of - in design

!%integer i
   set video mode(specialpad)            { To initialise the TERMLIB stuff
   setup designer
   show menu
!!%cycle
!i=testsymbol; %if i>=0 %start; write(i, 3); newline; %finish; %repeat
   do design
%end ;!of design

%externalroutine an clear
   %integer i,j
   %for i=0,1,31 %cycle; %for j=0,1,39 %cycle; virscreen(i,j)=0; %repeat; %repeat
   clear
%end

%routine act on (%integer comm, param)
   %switch entry('B':'H')
   %bytearray buffer(0:1279)
   %half page
   %integer rc, page id
   -> entry(comm)

entry('B'):  !Read a page from cache if available then broadcast if not
    page id = pg(channel, param)
    open cache(database file)
    read cached page(page id, pagestore, subpages)
    close cache
    %if channel = 5 %start
       flag error("Page not available") %if subpages=0
    %else
       %if subpages=0 %start
          flag error("Page not available")
       %elseif subpages=1
          show screen(pagestore,-1,-1)
       %else
          browse(pagestore, 0, subpages-1)
       %finish
    %finish
    %return

entry('C'):   !Change channel
    channel = param
    rc=server handshake(tostring(command).itos(channel,-1), 60, buffer, n)
    %return

entry('D'):   !Quit
   %if cache only # true %start
      rc=server handshake(tostring(command), 1, buffer, n)
      ether close(my port)
   %finish
   clear frame
   %return

entry('E'):  !Force a page request from server
   page id = pg(channel, param)
   open cache(database file)
   read cached page(page id, pagestore, subpages)
   close cache
   flag comment("Page from cache") %and showscreen(pagestore,-1,-1) %if subpages#0
   %if channel = 5 %start
      flag error("Cannot force a download on channel 5")
   %else
      %if cache only = true %start
          flag error("Trying to reconnect to server")
          %if start talking %start
             flag comment("OK.") 
             cache only = false
          %finish
      %finish

      %if cache only = false %start
          open cache(database file)
          rc=get page from server(param, pagestore, subpages)
          %if rc=0 %start
             %if subpages>1 %then browse(pagestore, 0, subpages-1)
             page id = pg(channel, param)
             flag comment 2("Caching page".snl."")
             write cached page(page id, pagestore, subpages)
          %else
             flag error("Page request failed - ".getfail(rc).snl. %c
             "Press <space> to continue")
             %cycle; %repeatuntil testsymbol=' '
          %finish
          close cache
      %else
          flag error("Cannot force page - server not responding")
      %finish
   %finish
   %return

entry('F'):
   show prompt("SAVE file name:");
   %cycle
      vt at(prompt row+1,menu col)
      read line(filename)
   %repeatuntil filename#""
   open output(1,filename)
   select output(1)
   %for i=0,1,32*40*subpages-1 %cycle
      print symbol(byteinteger(pagestore+i))
   %repeat
   close output
   select output(0)
   %return
   
entry('G'):
      open cache(database file)
      design
      close cache
      an clear
   %return

entry('H'):
   %if channel = 5 %start
      flag error("Cannot carousel on channel 5")
   %else
      open cache(database file)
      carousel(param)
      close cache
   %finish
%end


%routine get command(%integername comm, param)
   !Show menu, get and validate command.
   %ownbytearray table('1':'7') = 'B','E','C','F','H','G','D'
   %integer c
   %on 10 %start
      !Bad integer typed in.
      flag error("Bad integer supplied".snl.%c
      "Press space to continue")
      %cycle; %repeatuntil testsymbol=' '
   %finish

   clear frame %if graphics flag#0
   set shade(reverse+intense+blink+underline)
   title line("APMTEL on channel ".itos(channel,-1).":")
   set shade(0)
   line(1)
   print at line(menu row, %c
   "1:Get page".snl. %c
   "2:Force get".snl. %c
   "3:Channel".snl. %c
   "4:Save to file".snl. %c
   "5:Carousel page".snl. %c
   "6:Design page".snl. %c
   "7:QUIT".snl)
   !The explicitly written rows will put a | in rows 0-10.
   %if graphics flag=0 %start
      %for c=11,1,23 %cycle; vt at(c, divider col); printsymbol('|'); %repeat
   %finish
   flag error("".snl.""); flag comment("".snl."")
   show prompt("?:")
   %cycle
      c = test symbol
   %repeatuntil '1' <= c <= '7'

   comm = table(c); param=0
   %if comm='B' %or comm='H' %or comm='E' %start 
      ! 'B': Get page, 'E': Force get from broadcast, 'H': Carousel
      show prompt("Page:") 
      %cycle
         read(param)
         %exit %if 100<=param<=999
         flag error("Valid pages 100-999 only")
         vt at(prompt row+1,menu col)
      %repeat
   
   %elseif comm='C'
      !Select channel
      show prompt("Channel:") 
      %cycle
         read(param)
         %exit %if 1<=param<=5
         flag error("Valid channels 1 (BBC1), 2(BBC2), 3(STV), 4(Channel 4), 5(EUCSD) only")
         vt at(prompt row+1, menu col)
      %repeatuntil 1<=param<=5
   %elseif comm='D'
      !Quit
   %finish
!t!flag comment(itos(c, 3)." ".tostring(comm))
%end

%predicate flagset(%integer c)
  %integer i
  %false %if cli param=""
  %for i=1,1,length(cli param) %cycle
     %true %if charno(cli param,i) & 16_5F = c&16_5F
  %repeat
  %false
%end

%externalroutine load fonts
   readfont("apmtel:TFONT0.BFT",   font store (text))
   readfont("apmtel:TFONT1.BFT",   font store (graphics))
   readfont("apmtel:TFONT2.BFT",   font store (sep graphics))
   readfont("apmtel:TFONT0DH.BFT", font store (double text))
   readfont("apmtel:TFONT1DH.BFT", font store (double graphics))
   readfont("apmtel:TFONT2DH.BFT", font store (double sep graphics))
   font(font store(text))
   font w = max font width
   font h = font height
%end

   %if flagset('v') %then graphics flag=0 %elsestart
      %if graphics present %then graphics flag=1 %else graphics flag=0
   %finish
   pagestore = heapget(100*1280)
   set video mode(specialpad)
   clear frame
   channel = 1
   %if flagset('l') %then cache only = true %elsestart
      %if start talking %then cache only = false %else cache only = true
   %finish
   %if graphics flag#0 %start
      an clear
      flag comment("Loading fonts ")
      load fonts                 { Load the teletext fonts up
   %finish

   %cycle
      get command(command, param)       { Get a menu choice .....
      act on(command, param)
   %repeatuntil command='D'
  
   %if cache only # true %then etherclose (myport)
   heapput(pagestore)
%endofprogram