Smart Pascal Web Version of MorseCode

by Jack Fearn: Y13 Age ~18

Introduction

Click on the green up arrow at the foot of the page to see the original program. If the program does not work in your current browser after clicking on the display, try Chrome. If you see no display at school, the security system might have blocked it. You can try instead this direct link to the program running on its own page. The Smart Pascal code follows the program in action. You may insert a space with the right arrow to prevent Chrome's page-down action.

Output

MorseCode.html

Code of Main Unit

unit uMain;
{
    Copyright (c) 2011 Jack Fearn

    Licensed under the Apache License, Version 2.0 (the "License"); you may not
    use this file except in compliance with the License, as described at
    http://www.apache.org/licenses/ and http://www.pp4s.co.uk/licenses/

    Converted to Smart Pascal for web preview by PPS 2014
}

interface

uses 
  System.Types, SmartCL.System, SmartCL.Components, SmartCL.Application,
  SmartCL.Game, SmartCL.GameApp, SmartCL.Graphics, W3C.WebAudio, SmartCL.time, uCrtCanvas;

type
  TInputState = (isMenu, isEncrypt, isDecrypt, isInstructions);
  TReadState = (rsNotReading, rsReading, rsFinishedReading);

  TCanvasProject = class(TW3CustomGameApplication)
  private
    const DELAY = 2;
    const SCALE_FACTOR = 2;
    const CELL_WIDTH = 5 * SCALE_FACTOR;
    const CELL_HEIGHT = 8 * SCALE_FACTOR;
    const FONT_SIZE = 9 * SCALE_FACTOR;
    const ROWS = 25;
    const COLS = 80;
    const WIDTH = COLS * CELL_WIDTH;
    const HEIGHT = ROWS * CELL_HEIGHT;
    const SOUND_LEVEL = 0.1; // quiet
    const Pitch = 902;
    const Dot = 75;
    const Dash = 200;
    FSoundNum: integer = 1;
    FAudioContext: JAudioContext;
    FOscillator: JOscillatorNode;
    FGain: JGainNode;
    FDotTimer, FDashTimer, FSpaceTimer, FSilenceTimer: TW3Timer;
    Morse_Ascii : Array[1..90] of String =
   [{1}'','','','','','','','','','','','','','','','','','','','','','',
    '','','','', '','','','','',{32}'/ ',{*No proper code for '!'*}'',
    {34}'.-..-. ','','','','','.----. ', '-.--.- ', '-.--.- ','','','--..-- ',
    {45}'-....- ','.-.-.- ','-..-. ','----- ','.---- ','..--- ','...-- ','....- ',
    {53}'..... ','-.... ','--... ','---.. ','----. ','---... ','','','-...- ','',
    {63}'..--.. ','.--.-. ',{'A'}'.- ','-... ','-.-. ','-.. ','. ','..-. ','--. ',
    {72}'.... ','.. ','.--- ','-.- ','.-.. ','-- ','-. ','--- ','.--. ','--.- ',
    {82}'.-. ','... ','- ','..- ','...- ','.-- ','-..- ','-.-- ',{'Z'}'--.. '];
    Signal: String;
    Error: Boolean;
    Clear: Boolean := true;
    input_state: TInputState = isMenu;
    reading_state: TReadState = rsNotReading;
    TempReadString: string = '';
    Grid: TConsoleGrid;
    protected
      procedure ApplicationStarting; override;
      procedure ApplicationClosing; override;
      procedure PaintView(Canvas: TW3Canvas); override;
      procedure KeyDownEvent(mCode: integer);
      procedure GoToXY(X, Y: integer);
      procedure clrscr;
      procedure ClrEOL;
      procedure textColor(colour: TConsoleColour);
      procedure textBackground(colour: TConsoleColour);
      procedure write(txt: string);
      procedure writeln(txt: string); overload;
      procedure writeln; overload;
      procedure readln(var InputString : string);
      procedure Transmit(SignalX : String; SoundNum: integer);
      procedure Encrypt;
      procedure Decrypt;
      procedure Instructions;
      procedure HandleUpdate(Sender: TObject);
end;

implementation

var
  Choice, InstructionsChoice, Passage: string;

procedure TCanvasProject.ApplicationStarting;
begin
  inherited;
  FAudioContext := new JWebkitAudioContext;
  FGain := FAudioContext.createGain;
  FGain.connect(FAudioContext.destination);

  FDotTimer := new  TW3Timer;
  FDashTimer := new TW3Timer;
  FSpaceTimer := new TW3Timer;
  FSilenceTimer := new TW3Timer;
  FDotTimer.Delay := Dot;
  FDashTimer.Delay := Dash;
  FSpaceTimer.Delay := 200;
  FSilenceTimer.Delay := 80;
  FDotTimer.OnTime := HandleUpdate;
  FDashTimer.OnTime := HandleUpdate;
  FSpaceTimer.OnTime := HandleUpdate;
  FSilenceTimer.OnTime := HandleUpdate;

  Grid := new TConsoleGrid;
  Grid.Rows := ROWS;
  Grid.Cols := COLS;
  GameView.Width:= WIDTH;
  GameView.Height := HEIGHT;
  asm
    window.onkeydown = function(e)
    {
    TCanvasProject.KeyDownEvent(Self, e.keyCode);
    }
  end;
  KeyDownEvent(0);
  GameView.Delay := DELAY;
  GameView.StartSession(False);
end;

procedure TCanvasProject.KeyDownEvent(mCode: integer);
begin
  if mCode = 27 then
    begin
      case input_state of
        isEncrypt, isDecrypt, isInstructions: begin
                                                Choice := '';
                                                reading_state := rsNotReading;
                                                input_state := isMenu;
                                                clrscr;
                                                exit;
                                              end;
        isMenu: ApplicationClosing;
      end;
    end;

  if reading_state = rsReading then
    if mCode = 13 then
      reading_state := rsFinishedReading
    else
      begin
        case mCode of
          39:                     TempReadString += ' ';
          32, 48 .. 57, 65 .. 90: TempReadString += chr(mCode);
          189, 109:               TempReadString += '-';
          190, 110:               TempReadString += '.';
          191, 111:               TempReadString += '/';
          187:                    TempReadString += '=';
          188:                    TempReadString += ',';
        end;
      end;
end;

procedure TCanvasProject.GoToXY(X, Y: integer);
begin
  Grid.CursorX := X;
  Grid.CursorY := Y;
end;

procedure TCanvasProject.ClrScr;
begin
  Grid.ClearGrid;
  GoToXY(1, 1);
end;

procedure TCanvasProject.ClrEOL;
begin
  grid.ClearEol(Grid.CursorX, Grid.CursorY);
end;

procedure TCanvasProject.textColor(colour: TConsoleColour);
begin
  Grid.TextColour := colour;
end;

procedure TCanvasProject.textBackground(colour: TConsoleColour);
begin
  Grid.BackgroundColour := colour;
end;

procedure TCanvasProject.write(txt: string);
begin
  Grid.write(txt);
end;

procedure TCanvasProject.writeln(txt : string);
begin
  Grid.write(txt);
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TCanvasProject.writeln;
begin
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TCanvasProject.readln(var InputString : string);
begin
  case reading_state of
    rsReading:  write(TempReadString);
    rsNotReading: begin
                    reading_state := rsReading;
                    TempReadString := '';
                  end;
    rsFinishedReading: begin
                         InputString := TempReadString;
                         reading_state := rsNotReading;
                         writeln(TempReadString);
                       end;
  end;
end;

procedure TCanvasProject.Transmit(SignalX: String; SoundNum: integer);
begin
  case SignalX[SoundNum] of
    '-': begin
           FGain.gain.Value := SOUND_LEVEL;
           FDashTimer.Enabled := true;
           write('-');
         end;
    '.': begin
           FGain.gain.Value := SOUND_LEVEL;
           FDotTimer.Enabled := true;
           write('.');
         end;
    ' ': begin
           FGain.gain.Value := 0;
           FSpaceTimer.Enabled := true;
           write(' ');
         end;
    '/': begin
           FGain.gain.Value := 0;
           FSpaceTimer.Enabled := true;
           write('/');
         end;
    end; //case
  if SoundNum = length(Signal) then
    begin
      writeln('Sent!');
      FOscillator.stop(FAudioContext.currentTime);
    end;
end;

procedure TCanvasProject.Encrypt;
var
  CharCount : Integer;
begin
  if Clear then
    begin
      Signal := '';
      writeln('Enter passage to be encrypted. Press Enter when complete then Esc for menu.');
      gotoxy(1, 15);
      writeln('A : .-        B : -...      C : -.-.      D : -..       E : .   ');
      writeln('F : ..-.      G : --.       H : ....      I : ..        J : .---');
      writeln('K : -.-       L : .-..      M : --        N : -.        O : --- ');
      writeln('P : .--.      Q : --.-      R : .-.       S : ...       T : -   ');
      writeln('U : ..-       V : ...-      W : .--       X : -..-      Y : -.--');
      writeln('Z : --..      0 : -----     1 : .----     2 : ..---     3 : ...--');
      writeln('4 : ....-     5 : .....     6 : -....     7 : --...     8 : ---..');
      writeln('9 : ----.     " : .-..-.    '' : .----.   ( or ) : -.--.- ');
      writeln(', : --..--    - : -....-    . : .-.-.-    / : -..-. ');
      writeln(': : ---...    ; : -.-.-.    = : -...-     ? : ..--..    @ : .--.-.');
      gotoxy(1, 2);
      readln(Passage);
      if not ((reading_state = rsNotReading) and (length(Passage) > 0)) then
        exit;
      CharCount := Length(Passage);
      Passage := UpperCase(Passage);
      for var i := 1 to CharCount do
        begin
          if Ord(Passage[i]) <= 90 then
            begin
              Signal := Signal + (Morse_Ascii[Ord(Passage[i])]); // For playback with oscillator
              write(Morse_Ascii[Ord(Passage[i])]);
             end; // if Ord
        end; // for i
      Clear := False;
      FSoundNum := 1;
      writeln;
      FOscillator := FAudioContext.createOscillator;
      FOscillator.frequency.value := pitch;
      FOscillator.start(FaudioContext.currentTime);
      FGain.gain.value := SOUND_LEVEL;
      FOscillator.connect(FGain);
      Transmit(Signal, FSoundNum);
    end;
end;

procedure TCanvasProject.Decrypt;
var
  StartCode, Code, Letter, Translation : String;
  a, x, y, SpacePos : Integer;
begin
  if Clear then
    begin
      Clrscr;
      Translation := '';
      writeln('Enter code to be decrypted. Press Enter when complete then Esc for menu.');
      gotoxy(1, 15);
      writeln('A : .-        B : -...      C : -.-.      D : -..       E : .   ');
      writeln('F : ..-.      G : --.       H : ....      I : ..        J : .---');
      writeln('K : -.-       L : .-..      M : --        N : -.        O : --- ');
      writeln('P : .--.      Q : --.-      R : .-.       S : ...       T : -   ');
      writeln('U : ..-       V : ...-      W : .--       X : -..-      Y : -.--');
      writeln('Z : --..      0 : -----     1 : .----     2 : ..---     3 : ...--');
      writeln('4 : ....-     5 : .....     6 : -....     7 : --...     8 : ---..');
      writeln('9 : ----.     " : .-..-.    '' : .----.   ( or ) : -.--.- ');
      writeln(', : --..--    - : -....-    . : .-.-.-    / : -..-. ');
      writeln(': : ---...    ; : -.-.-.    = : -...-     ? : ..--..    @ : .--.-.');
      gotoxy(1, 3);
      readln(StartCode);
      if not ((reading_state = rsNotReading) and (length(StartCode) > 0)) then
        exit;
      Code := StartCode;
      a := length(Code);
      if not (Code[a] = ' ') then       // Most likely error when writing in
        begin
          Code := Code + ' ';
          a += 1;
        end; //If not
      repeat
        Error := True;
        SpacePos := Pos(' ', Code);
        Letter := leftStr(Code, SpacePos);
        Code := rightStr(Code, a-SpacePos);
        a := length(Code);
        for var i := 32 to 90 do
          begin
            if Letter = Morse_Ascii[i] then
              begin
                Translation := Translation + chr(i);
                Error := False;
              end; //If Letter
          end; //For i
      until Error or (Code = '');
      if Error then
        begin
          writeln;
          writeln('Error! Unable to decipher code:');
          writeln;
          x := Pos(Letter, StartCode);
          y := Grid.CursorY;
          writeln(StartCode);
          writeln;
          gotoxy(x,y);
          textcolor(red);
          writeln(Letter);
          textcolor(white);
        end
      else
        writeln(Translation);
    end; //if clear
  Clear := false
end;

procedure TCanvasProject.Instructions;
begin
  Clrscr;
  writeln('Morse Code is transmitted through different combinations of two signals: ');
  writeln;
  writeln('''.'' - short signal (often called "dots" or "dits")');
  writeln('''-'' - long signal (often called "dashes" or "dahs")');
  writeln;
  writeln('This program uses the . and - symbols (full stop and hyphen)');
  writeln('The morse code is written as so: ');
  writeln;
  writeln('".... . .-.. .-.. --- / .-- --- .-. .-.. -.. "');
  writeln;
  writeln('Each space represents the end of a character,');
  writeln('breaking the sequence up so it can be understood.');
  writeln;
  writeln('Each forward slash, represents the end of a word.');
  writeln('This must also be followed by a space.');
  writeln;
  writeln('Punctuation and numbers have their own set of signals.');
  writeln('Code must be input this way for the computer to understand.');
  writeln;
  writeln('For further online information, type 1, or to go back to the menu press Esc');
  writeln('If you type 1 your browser will direct you to www.learnmorsecode.com.' +
          ' When you have read it, click on the return icon (left arrow) of your ' +
          'browser to take you back to the menu.');
  readln(InstructionsChoice);
//  writeln(TempReadString);
  if TempReadString = '' then
    exit;
  if TempReadString = '1' then
    begin
      asm
        document.location.href = "http://www.learnmorsecode.com/";
      end;
      input_state := isMenu;
    end;
 end;

 procedure TCanvasProject.HandleUpdate(Sender: TObject);
 begin
   (Sender as TW3Timer).Enabled := false;
   if Sender = FSilenceTimer then
     begin  // next sound
       inc(FSoundNum);
       Transmit(Signal, FSoundNum);
     end
   else
     begin // silence between sounds
       FGain.gain.Value := 0;
       FSilenceTimer.Enabled := true;
     end;
 end;

procedure TCanvasProject.ApplicationClosing;
begin
  GameView.EndSession;
  Grid.Destroy;
  inherited;
end;

procedure TCanvasProject.PaintView(Canvas: TW3Canvas);

  procedure PaintGrid;
  begin
    Canvas.Font :=  IntToStr(FONT_SIZE) +'px Lucida Console';
    var currentChar: TCharacter;
    for var x := 1 to COLS do
      for var y := 1 to ROWS do
        begin
          currentChar := Grid.getCharacters[x, y];
          SetTextColor(currentChar.TextBackGroundColour, Canvas);
          Canvas.FillRect((x - 1) * CELL_WIDTH, ((y - 1) * CELL_HEIGHT) + 2, CELL_WIDTH, CELL_HEIGHT);
          SetTextColor(currentChar.TextColour, Canvas);
          Canvas.FillText(currentChar.Letter, (x - 1) * CELL_WIDTH, y * CELL_HEIGHT);
        end;
  end;

begin
  case input_state of
    isMenu: begin
              writeln('Morse Code Encrypter & Decrypter');
              writeln('1 - Encrypt');
              writeln('2 - Decrypt');
              writeln('3 - Code instructions/Help');
              writeln('4 - Quit');
              readln(Choice);
              case TempReadString of
                '': begin
                      PaintGrid;
                      ClrScr;
                      exit;
                    end;
                '1': begin
                       reading_state := rsNotReading;
                       input_state := isEncrypt;
                       Clear := true;
                       Choice := '';
                     end;
                '2': begin
                       input_state := isDecrypt;
                       reading_state := rsNotReading;
                       Clear := true;
                     end;
                '3': begin
                       reading_state := rsNotReading;
                       input_state := isInstructions;
                       InstructionsChoice := '';
                     end;
                '4': ApplicationClosing;
              end; //Case
              PaintGrid;
              clrscr;
       end;
    isEncrypt: begin
                 Encrypt;
                 PaintGrid;
                 if Clear then
                   clrscr;
               end;

    isDecrypt: begin
                 Decrypt;
                 PaintGrid;
                 if Clear then
                   clrscr;
               end;

    isInstructions: begin
                      Instructions;
                      PaintGrid;
                    end;
  end;
end;

end.

Code of Crt Unit

unit uCrtCanvas;

interface

uses 
  SmartCL.System, System.Colors, SmartCL.Graphics;

type
  TConsoleColour = (black, blue, green, cyan, red, magenta, brown, lightgray,
                    darkgray, lightblue, lightgreen, lightcyan, lightred, lightmagenta, yellow, white);

  TCharacter = record
    Letter: string = ' ';
    TextColour: TConsoleColour = white;
    TextBackgroundColour = black;
  end;

  TCharacters = array[1..80, 1..25] of TCharacter;

  TConsoleGrid = class
  private
    FTextColour: TConsoleColour = black;
    FBackgroundColour: TConsoleColour = white;
    FCursorX: integer = 1;
    FCursorY: integer = 1;
    FRows: integer = 25;
    FCols: integer = 80;
    FCharacters: TCharacters;
  public
    procedure setCharacters(Char: TCharacters);
    function getCharacters: TCharacters;
    procedure SetCursorX(newX: integer);
    procedure SetCursorY(newY: integer);
    procedure SetXY(newRec: TCharacter; X, Y: integer);
    function GetXY(X, Y: integer): TCharacter;
    procedure write(txt: string);
    procedure ClearEOL(startX, clearY: integer);
    procedure ClearCell(clearX, clearY: integer);
    procedure ClearGrid;
    property TextColour: TConsoleColour read FTextColour write FTextColour;
    property BackgroundColour: TConsoleColour read FBackgroundColour write FBackgroundColour;
    property CursorX: integer read FCursorX write SetCursorX;
    property CursorY: integer read FCursorY write SetCursorY;
    property Cols: integer read FCols write FCols;
    property Rows: integer read FRows write FRows;
  end;

procedure SetTextColor(colour: TConsoleColour; Canvas : TW3Canvas);

implementation

procedure SetTextColor(colour: TConsoleColour; Canvas : TW3Canvas);
begin
  case colour of
    black: Canvas.FillStyle := 'black';
    white: Canvas.FillStyle := 'white';
    brown: Canvas.FillStyle := ColorToWebStr(clBrown);
    red: Canvas.FillStyle := 'red';
    magenta: Canvas.FillStyle := ColorToWebStr(clMagenta);
    yellow: Canvas.FillStyle := 'yellow';
    green: Canvas.FillStyle := 'green';
    cyan: Canvas.FillStyle := ColorToWebStr(clCyan);
    blue: Canvas.FillStyle := 'blue';
    lightgray: Canvas.FillStyle := ColorToWebStr(clLightGray);
    darkgray: Canvas.FillStyle := ColorToWebStr(clDarkGray);
    lightred: Canvas.FillStyle := 'rgb(250, 130, 130)';
    lightmagenta: Canvas.FillStyle := 'rgb(250, 130, 250)';
    lightgreen: Canvas.FillStyle := ColorToWebStr(clLightGreen);
    lightcyan: Canvas.FillStyle := ColorToWebStr(clLightCyan);
    lightblue: Canvas.FillStyle := 'rgb(130, 130, 250)';
  end;
end;

procedure TConsoleGrid.setCharacters(Char: TCharacters);
begin
  FCharacters := Char;
end;

function TConsoleGrid.getCharacters: TCharacters;
begin
  Result := FCharacters;
end;

procedure TConsoleGrid.SetCursorX(newX: integer);
begin
  if (newX > 0) and (newX <= Cols) then
    FCursorX := newX;
end;

procedure TConsoleGrid.SetCursorY(newY: integer);
begin
  if (newY > 0) and (newY <= Rows) then
    FCursorY := newY;
end;

procedure TConsoleGrid.SetXY(newRec: TCharacter; X, Y: integer);
begin
  if (X > 0) and (X <= Cols) and (Y > 0) and (Y <= Rows) then
    FCharacters[X, Y] := newRec;
end;

function TConsoleGrid.GetXY(X, Y: integer): TCharacter;
begin
  Result := getCharacters[X, Y];
end;

procedure TConsoleGrid.write(txt: string);
var
  tempchar: TCharacter;
begin
  for var i := 1 to length(txt) do
    begin
      tempChar.TextColour := TextColour;
      tempChar.TextBackgroundColour := BackgroundColour;
      tempChar.Letter := txt[i];
      SetXY(tempChar, CursorX, CursorY);
      if CursorX < (Cols - 1) then
        CursorX := CursorX + 1
      else
        begin
          CursorX := 1;
          CursorY := CursorY + 1;  //Scrolling not implemented yet
        end;
    end;
end;

procedure TConsoleGrid.ClearCell(clearX, clearY: integer);
var
  tempChar: TCharacter;
begin
  tempChar.TextBackgroundColour := BackGroundColour;
  tempChar.Letter := ' ';
  tempChar.TextColour := black; //Not needed
  SetXY(tempChar, clearX, clearY);
end;

procedure TConsoleGrid.ClearEOL(startX, clearY: integer);
begin
  for var x := startX to Cols do
    ClearCell(x, clearY);
end;

procedure TConsoleGrid.ClearGrid;
begin
  for var y := 1 to Rows do
    ClearEOL(1, y);
end;

end.
UpGreen03.png
Programming - a skill for life!

by Jack Fearn: L6 Age ~16

dita powered logo dita powered™. Copyright © 2010-17 Pascal Programming for Schools. All rights reserved.