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
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.