extra/morse/morse.factor

   1 ! Copyright (C) 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs combinators hashtables kernel lists math
   4 namespaces make openal parser-combinators promises sequences
   5 strings synth synth.buffers unicode.case ;
   6 IN: morse
   7
   8 <PRIVATE
   9 : morse-codes ( -- array )
  10     {
  11         { CHAR: a ".-"    }
  12         { CHAR: b "-..."  }
  13         { CHAR: c "-.-."  }
  14         { CHAR: d "-.."   }
  15         { CHAR: e "."     }
  16         { CHAR: f "..-."  }
  17         { CHAR: g "--."   }
  18         { CHAR: h "...."  }
  19         { CHAR: i ".."    }
  20         { CHAR: j ".---"  }
  21         { CHAR: k "-.-"   }
  22         { CHAR: l ".-.."  }
  23         { CHAR: m "--"    }
  24         { CHAR: n "-."    }
  25         { CHAR: o "---"   }
  26         { CHAR: p ".--."  }
  27         { CHAR: q "--.-"  }
  28         { CHAR: r ".-."   }
  29         { CHAR: s "..."   }
  30         { CHAR: t "-"     }
  31         { CHAR: u "..-"   }
  32         { CHAR: v "...-"  }
  33         { CHAR: w ".--"   }
  34         { CHAR: x "-..-"  }
  35         { CHAR: y "-.--"  }
  36         { CHAR: z "--.."  }
  37         { CHAR: 1 ".----" }
  38         { CHAR: 2 "..---" }
  39         { CHAR: 3 "...--" }
  40         { CHAR: 4 "....-" }
  41         { CHAR: 5 "....." }
  42         { CHAR: 6 "-...." }
  43         { CHAR: 7 "--..." }
  44         { CHAR: 8 "---.." }
  45         { CHAR: 9 "----." }
  46         { CHAR: 0 "-----" }
  47         { CHAR: . ".-.-.-" }
  48         { CHAR: , "--..--" }
  49         { CHAR: ? "..--.." }
  50         { CHAR: ' ".----." }
  51         { CHAR: ! "-.-.--" }
  52         { CHAR: / "-..-."  }
  53         { CHAR: ( "-.--."  }
  54         { CHAR: ) "-.--.-" }
  55         { CHAR: & ".-..."  }
  56         { CHAR: : "---..." }
  57         { CHAR: ; "-.-.-." }
  58         { CHAR: = "-...- " }
  59         { CHAR: + ".-.-."  }
  60         { CHAR: - "-....-" }
  61         { CHAR: _ "..--.-" }
  62         { CHAR: " ".-..-." }
  63         { CHAR: $ "...-..-" }
  64         { CHAR: @ ".--.-." }
  65         { CHAR: \s "/" }
  66     } ;
  67
  68 : ch>morse-assoc ( -- assoc )
  69     morse-codes >hashtable ;
  70
  71 : morse>ch-assoc ( -- assoc )
  72     morse-codes [ reverse ] map >hashtable ;
  73
  74 PRIVATE>
  75
  76 : ch>morse ( ch -- str )
  77     ch>lower ch>morse-assoc at* swap "" ? ;
  78
  79 : morse>ch ( str -- ch )
  80     morse>ch-assoc at* swap f ? ;
  81
  82 : >morse ( str -- str )
  83     [
  84         [ CHAR: \s , ] [ ch>morse % ] interleave
  85     ] "" make ;
  86
  87 <PRIVATE
  88
  89 : dot-char ( -- ch ) CHAR: . ;
  90 : dash-char ( -- ch ) CHAR: - ;
  91 : char-gap-char ( -- ch ) CHAR: \s ;
  92 : word-gap-char ( -- ch ) CHAR: / ;
  93
  94 : =parser ( obj -- parser )
  95     [ = ] curry satisfy ;
  96
  97 LAZY: 'dot' ( -- parser )
  98     dot-char =parser ;
  99
 100 LAZY: 'dash' ( -- parser )
 101     dash-char =parser ;
 102
 103 LAZY: 'char-gap' ( -- parser )
 104     char-gap-char =parser ;
 105
 106 LAZY: 'word-gap' ( -- parser )
 107     word-gap-char =parser ;
 108
 109 LAZY: 'morse-char' ( -- parser )
 110     'dot' 'dash' <|> <+> ;
 111
 112 LAZY: 'morse-word' ( -- parser )
 113     'morse-char' 'char-gap' list-of ;
 114
 115 LAZY: 'morse-words' ( -- parser )
 116     'morse-word' 'word-gap' list-of ;
 117
 118 PRIVATE>
 119
 120 : morse> ( str -- str )
 121     'morse-words' parse car parsed>> [
 122         [
 123             >string morse>ch
 124         ] map >string
 125     ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
 126
 127 <PRIVATE
 128 SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
 129
 130 : queue ( symbol -- )
 131     get source get swap queue-buffer ;
 132
 133 : dot ( -- ) dot-buffer queue ;
 134 : dash ( -- ) dash-buffer queue ;
 135 : intra-char-gap ( -- ) intra-char-gap-buffer queue ;
 136 : letter-gap ( -- ) letter-gap-buffer queue ;
 137
 138 : beep-freq ( -- n ) 880 ;
 139
 140 : <morse-buffer> ( -- buffer )
 141     half-sample-freq <8bit-mono-buffer> ;
 142
 143 : sine-buffer ( seconds -- id )
 144     beep-freq swap <morse-buffer> >sine-wave-buffer
 145     send-buffer id>> ;
 146
 147 : silent-buffer ( seconds -- id )
 148     <morse-buffer> >silent-buffer send-buffer id>> ;
 149
 150 : make-buffers ( unit-length -- )
 151     {
 152         [ sine-buffer dot-buffer set ]
 153         [ 3 * sine-buffer dash-buffer set ]
 154         [ silent-buffer intra-char-gap-buffer set ]
 155         [ 3 * silent-buffer letter-gap-buffer set ]
 156     } cleave ;
 157
 158 : playing-morse ( quot unit-length -- )
 159     [
 160         init-openal 1 gen-sources first source set make-buffers
 161         call
 162         source get source-play
 163     ] with-scope ; inline
 164
 165 : play-char ( ch -- )
 166     [ intra-char-gap ] [
 167         {
 168             { dot-char [ dot ] }
 169             { dash-char [ dash ] }
 170             { word-gap-char [ intra-char-gap ] }
 171         } case
 172     ] interleave ;
 173
 174 PRIVATE>
 175
 176 : play-as-morse* ( str unit-length -- )
 177     [
 178         [ letter-gap ] [ ch>morse play-char ] interleave
 179     ] swap playing-morse ; inline
 180
 181 : play-as-morse ( str -- )
 182     0.05 play-as-morse* ; inline