program teach (input, output);
 
  (*  Teach Morse Code
      Copyright (C) 1978
      Howard Cunningham  *)
 
  (*  Revision History
        04/18/78 Initial version adapted from 8080 *)
 
  (*  Reference
        "A Fully Automatic Morse Code Teaching
        Machine", QST (May 1977) ARRL, Newington,
        Conn.  *)
 
  label 1;
 
  const
    line = 62;         (* terminal line length *)
    maxnum = 36;       (* maximum alphabet size *)
    good = 0;          (* error rate bounds *)
    bad = 255;
    coderadix = 10;    (* morse packing interval *)
 
  type
    msec = 0..10000;   (* time in msec *)
    ticks = 0..32767;  (* realtime clock *)
    code = 1..111111;  (* morse code *)
    rate = good..bad;  (* error rates *)
    state = (off, on); (* sidetone oscillator states *)
 
  var
    letter: 0..maxnum; (* index of selected letter *)
    told: rate;        (* student told answer flag *)
    correct: boolean;  (* correct response flag *)
    num: 1..maxnum;    (* size of current alphabet *)
    give: msec;        (* response wait time *)
    column: 0..line;   (* remain print positions *)
    sent: ticks;       (* realtime letter sent *)
 
    (*  character code and error rate tables *)
 
    ascii: array [0..maxnum] of char;
    error: array [0..maxnum] of rate;
    morse: array [1..maxnum] of code;
 
 
  function realtime: ticks;
 
    (*  Interface subroutine to read the
        system realtime clock.  Returns
        elapsed number of clock ticks
        modulo a power of two.   *)
 
    extern;
 
 
  procedure buzzer (switch: state);
 
    (*  Interface subroutine to a remote
        audio oscillator.  Subroutine
        is called only when a change in
        state is required (i.e. sidetone
        generation is external).   *)
 
    extern;
 
 
  function response: boolean;
 
    (*  Interface subroutine to sense a
        user keyboard response.  If true
        is returned, get(input) should
        advance to the next character
        without delay.   *)
 
    extern;
 
 
  function random: integer;
 
    (*  Interface function to random
        number generator.  Returns
        0 < random < 2**15 with
        even distribution.  *)
 
    extern;
 
 
  procedure preset;
 
    (*  Initialize tables and control
        variables to a state approprate
        for the beginning of a lesson.   *)
 
    var
      i: 1..maxnum;
    begin
      num := 4;       (* minimum alphabet *)
      give := 3000;   (* idle response *)
      column := 0;    (* print positions *)
      for i := 1 to maxnum do
        error [i] := bad;
      error [0] := bad * 30 div 100;
      ascii [00] := "*";
      ascii [01] := "Q";  morse [01] := 11011;
      ascii [02] := "7";  morse [02] := 100011;
      ascii [03] := "Z";  morse [03] := 10011;
      ascii [04] := "G";  morse [04] := 1011;
      ascii [05] := "0";  morse [05] := 111111;
      ascii [06] := "9";  morse [06] := 101111;
      ascii [07] := "8";  morse [07] := 100111;
      ascii [08] := "O";  morse [08] := 1111;
      ascii [09] := "1";  morse [09] := 111110;
      ascii [10] := "J";  morse [10] := 11110;
      ascii [11] := "P";  morse [11] := 10110;
      ascii [12] := "W";  morse [12] := 1110;
      ascii [13] := "L";  morse [13] := 10010;
      ascii [14] := "R";  morse [14] := 1010;
      ascii [15] := "A";  morse [15] := 110;
      ascii [16] := "M";  morse [16] := 111;
      ascii [17] := "6";  morse [17] := 100001;
      ascii [18] := "B";  morse [18] := 10001;
      ascii [19] := "X";  morse [19] := 11001;
      ascii [20] := "D";  morse [20] := 1001;
      ascii [21] := "Y";  morse [21] := 11101;
      ascii [22] := "C";  morse [22] := 10101;
      ascii [23] := "K";  morse [23] := 1101;
      ascii [24] := "N";  morse [24] := 101;
      ascii [25] := "2";  morse [25] := 111100;
      ascii [26] := "3";  morse [26] := 111000;
      ascii [27] := "F";  morse [27] := 10100;
      ascii [28] := "U";  morse [28] := 1100;
      ascii [29] := "4";  morse [29] := 110000;
      ascii [30] := "5";  morse [30] := 100000;
      ascii [31] := "V";  morse [31] := 11000;
      ascii [32] := "H";  morse [32] := 10000;
      ascii [33] := "S";  morse [33] := 1000;
      ascii [34] := "I";  morse [34] := 100;
      ascii [35] := "T";  morse [35] := 11;
      ascii [36] := "E";  morse [36] := 10;
    end;
 
 
  function elapsed (start: ticks): msec;
 
    (*  Computes elapsed time, in msec,
        from a given start time to
        the present.  Maximum measurable
        time is clocksize-1 ticks   *)
 
    const
      clocksize = 32768;
      period = 17;   (* clock period in msec *)
    begin
      elapsed := (realtime-start+clocksize)
        mod clocksize * period;
    end;
 
 
  procedure wait (period: msec);
 
    (*  Delay execution for the
        indicated period of time
        (in msec).   *)
 
    var
      start: ticks;
    begin
      start := realtime;
      while elapsed (start) < period do
        (* idle time code can go here *) ;
    end;
 
 
  procedure weight (var old: integer; new: integer);
 
    (*  Adjust old value by a weighted
        average with a new value.  This
        approximates the damping of an
        r-c lowpass filter.   *)
 
    const
      percent = 0.125;
    begin
      old := round ((1.0-percent) * old
        + percent * new);
    end;
 
 
  procedure return;
 
    (*  Generate local carriage return and
        line feed on print device.  Column
        counter is reset to maximum.   *)
 
    begin
      writeln (output);
      column := line;
    end;
 
 
  procedure print (character: char);
 
    (*  Output a single character.  A new
        line is generated when the current
        line is filled.  Unbuffered output
        is required.    *)
 
    begin
      if column = 0 then return;
      output^ := character;
      put (output);
      column := column - 1;
    end;
 
 
  procedure select;
 
    (*  Select a test letter from the current
        alphabet with selection probability
        proportional to the current error
        rate function.   *)
 
    var
      sum: integer;
    begin
      sum := 0;
      for letter := 1 to num do
        sum := sum + error [letter] + 1;
      sum := random mod sum;
      letter := num + 1;
      repeat
        letter := letter - 1;
        sum := sum - error [letter] - 1;
      until sum <= 0;
    end;
 
 
  procedure send;
 
    (*  Send a morse code letter via
        the buzzer procedure.  Morse
        characters are encoded with
        a stop bit appended (see ref.)  *)
 
    const
      dittime = 80;  (* 15 wpm *)
    var
      assembly: code;
    begin
      assembly := morse [letter];
      repeat
        buzzer (on);
        if odd (assembly) then
          wait (3*dittime)
        else
          wait (dittime);
        buzzer (off);
        wait (dittime);
        assembly := assembly div coderadix;
      until assembly = 1;
    end;
 
 
  procedure grade;
 
    (*  Adjust individual and overall error
        rate estimations.  If both are
        suficiently low, increase the
        alphabet size.   *)
 
    label 2;
    const
      overall = 0;
    begin
      weight (error [overall], told);
      weight (error [letter], told);
      if error [overall] < 0.30 * bad then
      begin
        if error [overall] < 0.10 * bad then
          weight (error [letter], told);  (* twice *)
        for letter := 1 to num do
          if error [letter] > 0.40 * bad then goto 2;
        if num < maxnum then num := num + 1;
2:      (* exit to here if more practice needed *)
      end;
    end;
 
 
  procedure graph;
 
    (*  Display error rate function as
        a bar graph.  Wait for any response
        before resuming instruction.   *)
 
    var
      count: 0..line;
    begin
      for letter := num downto 0 do
      begin
        print (" ");
        print (ascii [letter]);
        print (" ");
        for count := 1
          to round ((line-3) * error [letter] / bad) do
          print ("*");
        return;
      end;
      while not response do wait (20);
    end;
 
 
  (* main program *)
 
  (*  The basic instruction loop
      structure can be outlined
      as follows:
 
        repeat
          select letter
          repeat
            send letter
            repeat
              check response
            until correct or timeout
            print letter
          until correct
          adjust probabilities
        until forever    *)
 
  begin
    preset;
1:  graph;
    repeat
      select;
      told := good;
      repeat
        send;
        sent := realtime;
        correct := false;
        if response then get (input);  (* ignore *)
        repeat
          wait (20);
          if response then
          begin
            get (input);
            if input^ = "?" then goto 1
            else correct := input^ = ascii [letter];
          end;
        until correct or (elapsed (sent) > give);
        print (" ");
        print (ascii [letter]);
        if not correct then told := bad;
        weight (give, 2 * elapsed (sent));
        if give > 5000 then give := 5000;
        wait (250);
      until correct;
      grade;
    until false;
  end.