Keskustelu: Koodit: 8th: Morse koodin tulkkaus

ns?  \ Get current namespace

ns: morse

private  \ Following are private to the file

[ ".-",  "-...", "-.-.", "-..",  ".",    "..-.",
  "--.",  "....", "..",   ".---", "-.-",  ".-..",
  "--",   "-.",   "---",  ".--.", "--.-", ".-.",
  "...",  "-",    "..-",  "...-", ".--",  "-..-",
  "-.--", "--.." ] constant morse-code

[ `'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` ] constant alphabet

null var, root

: new-node
  { "left" : null , "right" : null, "character" : ` '? ` } const ;

: short
  "p" t:@ "left" m:@
  null? if
    drop
    "left" #p:new-node m:!
    "left" m:@ nip
  else
    nip
  then
  "p" t:! ;

: long
  "p" t:@ "right" m:@
  null? if
    drop
    "right" new-node m:!
    "right" m:@ nip
  else
    nip
  then
  "p" t:! ;

: dot
  "p" t:@ null? not if
    "left" m:@ nip "p" t:!
  else
    drop
  then ;

: line
  "p" t:@ null? not if
    "right" m:@ nip "p" t:!
  else
    drop
  then ;

: spc
  "p" t:@ root @ same? not if
    "p" t:@ null? not if
      "msg" t:@ swap "character" m:@ nip s:+ "msg" t:!
    else
      drop
      "msg" t:@ '? s:+ "msg" t:!
    then
  then
  root @ "p" t:! ;

public  \ Following are public inside the namespace

: translate  \ s -- s
  \ If this is the first call, then setup the binary tree
  #p:root lock @ null? if
    drop
    #p:new-node #p:root !
    #p:morse-code
    ( swap >r
      #p:root @ "p" t:!
      (
        [ ` '. ` , ` '- ` ] swap
        ' n:= a:indexof nip
        [ ' #p:short , ' #p:long ] swap
        caseof
      ) s:each!
      "p" t:@ "character" #p:alphabet r@ a:@ nip m:! drop
      rdrop
    ) a:each drop
  else
    drop
  then

  \ Translate morse code
  #p:root unlock @ "p" t:!
  "" "msg" t:!
  (
    [ ` '. ` , ` '- ` , 32 ] swap
    ' n:= a:indexof nip
    "Error, unknown character to translate" thrownull

    [ ' #p:dot , ' #p:line , ' #p:spc ] swap
    caseof
  ) s:each!

  "p" t:@ #p:root @ same? not if
    "p" t:@ null? not if
      "msg" t:@ swap "character" m:@ nip s:+ "msg" t:!
    else
      drop
      "msg" t:@ '? s:+ "msg" t:!
    then
  then
  "msg" t:@ ;

ns  \ Restore namespace

needs map/iter

[ ".-",  "-...", "-.-.", "-..",  ".",    "..-.",
  "--.",  "....", "..",   ".---", "-.-",  ".-..",
  "--",   "-.",   "---",  ".--.", "--.-", ".-.",
  "...",  "-",    "..-",  "...-", ".--",  "-..-",
  "-.--", "--.." ] constant morse-code

[ "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" ] constant alphabet

morse-code alphabet m:zip constant translate-to-map
alphabet morse-code m:zip constant translate-from-map

\ Translate morse code to alphabets
: >translate  \ s -- s
  a:new swap
  " "s:/ translate-to-map swap ( "?" m:@? 2 pick swap a:push drop ) m:iter drop
  "" a:join ;

\ Translate alphabets to morse code
: translate>  \ s -- s
  a:new swap
  "" s:/ translate-from-map swap ( "?" m:@? 2 pick swap a:push drop ) m:iter drop
  " " a:join ;

: app:main
  ".... . .-.. .-.. ---" >translate .
  space
  ".-- --- .-. .-.. -.." >translate .
  bye ;