extra/morse/morse.factor

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