SECTION "Cifer"

GET "LIBHDR"
GET "SIM3270HDR"

MANIFEST $( esc     =    #X1B
            cr      =    #XD
            bs      =    8
            lf      =    #XA
         $)

LET clear.display() BE
$( outch(esc); outch('J')
   FOR i = 0 TO 1920/bytesperword-1 DO
   $( dba!i := 0
      dbb!i := 0
   $)

   // clear field list
   $( LET ll = la
      la := -1
      UNTIL ll=-1 DO
      $( LET lll = !ll
         free.ele(ll)
         ll := lll
      $)
   $)

   ca, rca := 0, 0
   curruat := 0; curruatp := -1

$)


AND highlights.off() BE
$( outesc('X')
   outesc('+')
   highlighting := FALSE
$)


AND highlights.on() BE
$( outesc('Y')
   outesc('+')
   highlighting := TRUE
$)


AND setup.display() BE
$( outesc('=')
   outesc('J')
   outesc('N')    // enable highlighting (model 2605-04)
   outesc('+')    // copy highlight status
   outesc('X')    // half intensity on
   outesc('+')
   outesc('M')    // inverted video off
   outesc('+')
$)

AND unsetup.display() BE
$( outesc('7')
   outesc('O')
$)


AND outesc(c) BE
$( outch(esc)
   outch(c)
$)


AND keyboard.lock() BE outesc('"')


AND set.cursor(c) BE
$( ca := c
   UNLESS rca=ca DO
   $(
   outch(esc)
   outch('P')
   outch(c REM 80)
   outch(c/80)
   rca := ca
   $)
   find.user(ca)
$)


AND sound.alarm() BE
   outch(7)


AND clear.line(ad) BE
$( // clear line on display from address ad
   UNLESS rca=ad DO
   $( outesc('P')
      outch(ad REM 80)
      outch(ad/80)
      rca := ad
   $)
   outesc('K')     // CLEAR TO END OF LINE
$)


AND keyboard.restore() BE
$( aid := #X60    // reset AID byte
   outch(esc)
   outch('$')
$)


    /* dispch routine for CIFER terminals (2605).
       Puts character at given address in dba, also writes
       it to the screen. Determines a good way to move
       the cursor. Must also restore cursor to correct
       address for input if no more.to.display.
       Cursor address on screen is given by rca,
       cursor address for user by ca.

       Cifer should be set up with:
       esc 8          roll mode, fixed screen
       esc J          clear screen

       Controls used:
       esc C          cursor right
       bs             backspace
       esc !          cursor to end of line
       cr             carriage return
       esc _          cursor bottom (left)
       lf             line feed
       esc @          cursor down
       esc A          cursor up

       esc :          reverse line feed
       esc "          keyboard lock
       esc $          keyboard unlock
       esc P x y      move cursor to col x row y

       Uses cursor position command unless other commands
       can effect change in 0, 1, 2 or 3 characters.
       Cursor will often be in correct place if writing
       a field.

    */

AND dispch(a, ch) BE
$( LET dch = dba%a
   LET ach = ascii(ch)

   dba%a := ch

   UNLESS ((#X20<ach<=#X7E)|(#X20<ascii(dch)<=#X7E))&(ch~=dch) DO
          // if blank on blank or characters same return
      RETURN

   UNLESS a=rca DO    // dont bother to move if already OK
   $( TEST a=0 DO      // use cursor home
      $( outch(esc); outch('H') $)
      OR
      $( TEST a=1840 DO // use cursor bottom
         $( outch(esc); outch('_') $)
         OR        // try others
         $(
            LET row = a/80
            LET col = a REM 80
            LET rowc = rca/80
            LET colc = rca REM 80
            LET vd = ABS(row-rowc)
            LET hd = ABS(col-colc)

            UNLESS hd=0 DO IF col=0 DO hd := 1
            UNLESS hd<=1 DO IF col=79 DO hd := 2
            UNLESS vd=0 DO IF rowc>row DO vd := vd<<1 // weighted

            TEST vd+hd<=3 DO
            $( UNLESS hd=0 DO   // move horizontally
               TEST col=0 DO    // use cr
                  outch(cr)
               OR
               $( TEST col=79 DO // move to end of line
                  $( outch(esc); outch('!') $)
                  OR
                  $( TEST col>colc DO
                     $( LET bas = rowc*80
                        FOR i = colc+bas TO col+bas-1 DO
                        $( LET cc = ascii(dba%i)
                           TEST #X20<=cc<=#X7E DO outch(cc)
                                               OR outch('*S')
                        $)
                     $)
                     OR FOR i = 1 TO colc-col DO outch(bs)
                  $)
               $)

               UNLESS vd=0 DO   // move vertically
                  TEST row>rowc DO
                     FOR i = 1 TO row-rowc DO outch(lf)
                  OR FOR i = 1 TO rowc-row DO $( outch(esc); outch(':') $)
            $)
            OR     // use cursor position command
            $( outch(esc); outch('P')
               outch(col); outch(row)
            $)
         $)
      $)
   $)

   UNLESS #X20<=ach<=#X7E DO ach := '*S'
   outch(ach)
   UNLESS a=1919 DO a := a+1
   rca := a
   UNLESS more.to.display DO set.cursor(a)

$)


AND handle.ch(ch) BE // handle character typed by the user
$(  /* The user has the ability to
       .  move the cursor about
       .  enter characters into display
       .  use special function keys to cause data transmission

       The cifer keyboard has to emulate the 3277 keyboard.
       Some keys will behave as usual, others have altered functions
       and others will be ignored.
       The program has control of the screen at all times, LOCAL mode
       and ECHO ON are not used.

       The keys are handled as follows:
       clear scrn       esc B      performs clear AID byte, clears buffer
                                   and display (esc J) (cursor to 0)
       cursor down      esc @      move cursor down
       cursor up        esc A      move cursor up
       cursor left      esc D      move cursor left
       cursor right     esc C      move cursor right
                        esc !      move cursor to end of line
       home             esc H      move cursor to home position
                        esc _      move cursor to bottom left position
       rev line feed    esc :      as cursor up
                        esc esc    write esc in buffer
       clear line       esc K      erase to end of field
                        esc 0      erase input
                        esc 8      insert mode
                        esc 9      cancel insert mode

       All other escapes are illegal except 1, 2 and 3 (see below).

       Program attention keys:
       CLEAR         use       clear
       ENTER          "        return
       PA1            "        esc 1
       PA2            "        esc 2
       PA3            "        esc 3
       PF1            "        ctrl-A
       PF2            "        ctrl-S
       PF3            "        ctrl-D
       PF4            "        ctrl-F
       PF5            "        ctrl-G
       PF6            "        ctrl-H
       PF7            "        ctrl-Z
       PF8            "        ctrl-X
       PF9            "        ctrl-C
       PF10           "        ctrl-V
       PF11           "        ctrl-B
       PF12           "        ctrl-N

       The following characters behave 'as expected' (printing characters).
       They are entered at the current cursor position and the cursor moves
       right.

       sp !  "  #  $  %  &  '  (  )  *  +  ,  -  .  /
       0  1  2  3  4  5  6  7  8  9  :  ;  <  =  >  ?
       @  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O
       P  Q  R  S  T  U  V  W  X  Y  Z  [  \  ]  ^  _
       a  b  c  d  e  f  g  h  i  j  k  l  m  n  o
       p  q  r  s  t  u  v  w  x  y  z  {  |  }  ~

       any other characters, controls or otherwise are ignored.

    */

   SWITCHON ch INTO     // seems like a good idea
   $( CASE esc:
         IF escing DO safeprint(esc)
         escing := ~escing
         ENDCASE

      CASE 'A': CASE 'B': CASE 'C': CASE 'D': CASE 'H':
      CASE '@': CASE '!': CASE '_': CASE ':': CASE 'K':
      CASE '1': CASE '2': CASE '3':
      CASE '8': CASE '9': CASE '0':
         IF escing DO
         $( escing := FALSE

            SWITCHON ch INTO
            $( CASE ':':
               CASE 'A':
                  outesc('A')       // cursor up
                  TEST ca/80=0 DO
                     ca := 23*80 + ca REM 80
                  OR ca := ca-80
                  rca := ca
                  find.user(ca)       // sets curruat and curruatp
                  ENDCASE

               CASE 'B':
                  clear.display()
                  aid := #X6D
                  cba := 0; currat := 0
                  read.modified()
                  ENDCASE

               CASE 'C':
                  outesc('C')      // cursor right
                  ca := ca=1919 -> 0, ca+1
                  rca := ca
                  find.user(ca)
                  ENDCASE

               CASE 'D':
                  outch(bs)
                  ca := ca=0 -> 1919, ca-1
                  rca := ca
                  find.user(ca)
                  ENDCASE

               CASE '_':
                  outesc('_')      // cursor bottom left
                  ca := 1840
                  rca := ca
                  find.user(ca)
                  ENDCASE

               CASE '@':
                  TEST ca/80=23 DO
                  $( ca := ca REM 80
                     outesc('@')
                  $)
                  OR
                  $( ca := ca+80
                     outch(lf)
                  $)
                  rca := ca
                  find.user(ca)
                  ENDCASE

               CASE '!':
                  outesc('!')    // cursor to end of line
                  ca := (ca/80)*80+79
                  rca := ca
                  find.user(ca)
                  ENDCASE

               CASE '1':CASE '2': CASE '3':
                  aid := ch='1' -> #X6C, // PA1
                         ch='2' -> #X6E, // PA2
                                   #X6B  // PA3
                  read.modified()
                  ENDCASE

               CASE '8':
                  insert.mode.on := TRUE
                  ENDCASE

               CASE '9':
                  insert.mode.on := FALSE
                  ENDCASE

               CASE '0':
   $( LET fuf = FALSE // unprotected fields found
      LET fpf = FALSE // protected fields found
      LET fu = 0     // address of first unprotected field
      LET a = next.attribute(0)

      UNTIL a=-1 DO                  // until no more fields
      $( LET b = a=1919 -> -1, next.attribute(a+1)
         LET c = b=-1 -> 1920, b
         currat := dbb%a

         TEST bit(currat, 2) DO fpf := TRUE OR        // unless protected
         $( dbb%a := dbb%a & #XFE   // reset MDT bit
            a := a+1
            fuf := TRUE
            IF fu=0 DO fu := a
            UNTIL a=c DO
            $( dispch(a, null)
               a := a+1
            $)
         $)
         a := b
      $)

      UNLESS fpf | fuf DO clear.display()

      set.cursor(fu)
   $)
   ENDCASE

               CASE 'H':           // cursor home
                  outesc('H')
                  ca := 0
                  rca := 0
                  find.user(ca)
                  ENDCASE

               CASE 'K':
               $( // erase to end of field
                  LET a = next.attribute(ca)  // rh limit
                  LET ns = ?
                  LET i = ca
                  LET es = ebcdic('*S')

                  IF curruatp<0 | ca=curruatp ENDCASE
                  IF a=ca | bit(curruat, 2) ENDCASE

                  IF a<0 DO a := 1920
                  a := a-1

                  ns := highlight.check()

                  $( outch('*S')
                     dba%i := es
                     i := i+1
                  $) REPEATUNTIL i>a

                  UNLESS ns=0 DO outesc(ns)
                  dbb%curruatp := curruat | 1 // set modified bit

                  UNLESS ca=1919 DO
                  $( rca := i
                     set.cursor(ca)
                  $)
               $)
               $)
               ENDCASE
            $)

            CASE '*S': CASE '*"': CASE '#': CASE '$': CASE '%': CASE '&':
            CASE '*'': CASE '(': CASE ')': CASE '**': CASE '+': CASE ',':
            CASE '-': CASE '.': CASE '/': CASE '4':
            CASE '5': CASE '6': CASE '7': CASE ';':
            CASE '<': CASE '=': CASE '>': CASE '?': CASE 'E': CASE 'F':
            CASE 'G': CASE 'I': CASE 'J': CASE 'L': CASE 'M':
            CASE 'N': CASE 'O': CASE 'P': CASE 'Q': CASE 'R': CASE 'S':
            CASE 'T': CASE 'U': CASE 'V': CASE 'W': CASE 'X': CASE 'Y':
            CASE 'Z':
            CASE '[': CASE '\': CASE ']': CASE '^':
            CASE 'a': CASE 'b': CASE 'c': CASE 'd': CASE 'e': CASE 'f':
            CASE 'g': CASE 'h': CASE 'i': CASE 'j': CASE 'k': CASE 'l':
            CASE 'm': CASE 'n': CASE 'o': CASE 'p': CASE 'q': CASE 'r':
            CASE 's': CASE 't': CASE 'u': CASE 'v': CASE 'w': CASE 'x':
            CASE 'y': CASE 'z':
            CASE '{': CASE '|': CASE '}': CASE '~':
               TEST insert.mode.on DO
               $( LET a = next.attribute(ca)  // rh limit
                  LET i = ca
                  LET ns = ?
                  IF curruatp<0 | ca=curruatp ENDCASE
                  IF a=ca | bit(curruat,2) ENDCASE

                  IF a<0 DO a := 1920
                  a := a-1

                  ns := highlight.check()

                  $( LET tc = ascii(dba%i)  // will go over end of dba!
                     TEST safe.for.terminal(ch) DO outch(ch) OR outch('*S')
                     dba%i := ebcdic(ch)
                     i := i+1
                     ch := tc
                  $) REPEATUNTIL i>a

                  UNLESS ns=0 DO outesc(ns)

                  dbb%curruatp := curruat | 1 // set modified bit
                  UNLESS ca=1919 DO
                  $( rca := a+1
                     set.cursor(ca+1)
                  $)
               $)
               OR safeprint(ch)
               ENDCASE

            CASE tab:    // tab key
            $( LET a1 = ca

               UNTIL a1=-1 DO
               $( a1 := next.attribute(a1)
                  UNLESS a1=-1 DO $( a1 := a1+1
                                     IF ~bit(dbb%(a1-1),2) DO BREAK
                                  $)
               $)

               IF a1=-1 DO
               $( a1 := 0

                  UNTIL a1=-1 | a1>ca DO
                  $( a1 := next.attribute(a1)
                     UNLESS a1=-1 DO $( a1 := a1+1
                                        IF ~bit(dbb%(a1-1),2) DO BREAK
                                     $)
                  $)
                  IF a1=-1 DO a1 := 0
               $)
               IF a1>1919 DO a1 := 0
               set.cursor(a1)
               ENDCASE
            $)

            CASE lf:            // newline
               $( LET line = ca/80
                  UNLESS line>=23 DO
                  $( LET lina = (line+1)*80   // first address on new line
                     LET a = find.attribute(lina)

                     UNTIL a=-1 | lina=1919 | (lina/80)~=(line+1) DO
                     $( UNLESS bit(dbb%a, 2) DO
                        $( set.cursor(a=lina -> lina+1, lina)
                           ENDCASE
                        $)
                        a := next.attribute(a+1)
                        lina := a
                     $)
                  $)
                  ENDCASE
               $)

            CASE del:
               $( LET a = next.attribute(ca)   // rh limit
                  LET i, ch = ca, ?
                  LET ns = ?

                  IF curruatp<0 | ca=curruatp ENDCASE
                  IF a=ca | bit(curruat, 2) ENDCASE

                  UNLESS a/80=ca/80 DO a := -1
                  a := a=-1 -> (ca/80)*80 + 79, a-1

                  ns := highlight.check()

                  $( ch := i=a -> 0, dba%(i+1)
                     ch := ascii(ch)
                     TEST safe.for.terminal(ch) DO outch(ch) OR outch('*S')
                     dba%i := ebcdic(ch)
                     i := i+1
                  $) REPEATUNTIL i>a

                  UNLESS ns=0 DO outesc(ns)

                   dbb%curruatp := curruat | 1 // set modified bit
                  rca := a=1919 -> 1919, a+1
                  set.cursor(ca)
               $)
               ENDCASE

            CASE ctrl.Q:
               abort(#X1010, ca)         // escape to DEBUG
               ENDCASE                   // continue

            CASE ctrl.W:
               user.terminate()
               exstring := "user terminated"
               ENDCASE

            CASE cr: aid := #X7D; GOTO rma
            CASE ctrl.A: aid := #XF1; GOTO rma
            CASE ctrl.S: aid := #XF2; GOTO rma
            CASE ctrl.D: aid := #XF3; GOTO rma
            CASE ctrl.F: aid := #XF4; GOTO rma
            CASE ctrl.G: aid := #XF5; GOTO rma
            CASE ctrl.H: aid := #XF6; GOTO rma
            CASE ctrl.Z: aid := #XF7; GOTO rma
            CASE ctrl.X: aid := #XF8; GOTO rma
            CASE ctrl.C: aid := #XF9; GOTO rma
            CASE ctrl.V: aid := #X7A; GOTO rma
            CASE ctrl.B: aid := #X7B; GOTO rma
            CASE ctrl.N: aid := #X7C
        rma: read.modified()

         $)
$)


AND highlight.check() = VALOF
                  $( LET newhi = bit(curruat,4) & ~bit(curruat,5)
                     IF newhi & ~highlighting DO
                     $( outesc('Y');outesc('+'); RESULTIS 'X' $)
                     IF highlighting & ~ newhi DO
                     $( outesc('X'); outesc('+');RESULTIS 'Y' $)
                     RESULTIS 0
                  $)


AND safeprint(ch) BE
$(
   TEST bit(curruat, 2) | dbb%ca~=0 DO sound.alarm() // prot. or attr.
   OR
   $( LET ns = highlight.check()
   TEST safe.for.terminal(ch) & ~[bit(curruat,4) & bit(curruat,5)] DO
      outch(ch)
   OR
      outch('*S')
   dba%ca := ebcdic(ch)
   UNLESS ca=1919 DO
   $( ca := ca+1
      rca := ca
   $)
   UNLESS curruatp=-1 DO dbb%curruatp := curruat | 1  // set modified bit
   UNLESS ns=0 DO outesc(ns)
  $)
$)


AND safe.for.terminal(ch) = #X20 <= ch <= #X7E