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