KCS.LST

\ Information

Conversion utility for Kansas City Standard and Computer Users
Tape Standard (Processor Technology) formatted tapes.

The decoding algorithm is derived from that found in
Wouter Ras' ATOMTAPE utility.









\ Load - main screen
empty  forth definitions  decimal
application  warning on

: TITLE ." KCS version 0.8  28-Jan-06" cr ;

cr .( Compiling: )  title  2 load

cr .( Save to disk? )  y/n
[if]
\  pad reserve @ + 256 + limit s0 @ - + set-limit
  turnkey program  KCS
[then]



\ Load - defaults
variable RESERVE  0 reserve !       \ reserved memory tally
defer ?BREAK  ' noop is ?break      \ break check off
defer SET-IO  ' bios-io is set-io   \ default console mode
defer ERRFIX  ' noop is errfix      \ reset on-error handler

blk @ 1+ #screens 1- thru       \ load electives & application

 ' (?break) is ?break           \ enable user break
\ ' dos-io is set-io             \ enable console redirection
\ ' deloutfile +is errfix        \ delete outfile on error
\ wrtchk off                     \ disable overwrite check




\ Load - electives
 1 fload DOSLIB     \ load DOSLIB library

 _Errors            \ error handler
 _Inout1            \ number output
 _Inout2            \ string & number input
 _String1           \ basic strings
\ _String2           \ extra strings
 _Parsing           \ command-line parsing
 _Fileprims         \ file primitives
 _Files             \ default files
 _Bufinfile         \ buffered input file
 _Bufoutfile        \ buffered output file



\ Help screen - HELP
: HELP  ( -- )  dos-io  cr cr title
  cr ." Use:  KCS [options] infile[.typ] [outfile[.typ]]" cr
  cr ." -X    strict decoding             -M    make wavefile"
  cr ." -C    console output              -O    odd parity"
  cr ." -Bn   baud  1=600 2=1200          -E    even parity"
  cr ." -U    CUTS mode (1200 baud)       -D    7 data bits"
  cr ." -V    VOC wavefile                -S    1 stop bit"
  cr ." -R    RAW wavefile                -Ln   leader (sec)"
  cr ." -Fn   offset  -127 to 127         -Pn   pacing (msec)"
  cr ." -Hn   hysteresis  0 to 127        -T    sine tone"
  cr ." -Gn   timing  -2 to 2             -I    invert output"
  cr ." -Nn   nulls (after CR if n<0)     -Y    ignore errors"
  cr


\ Help screen - HELP
  cr ." default: decode WAV file, Kansas City Standard,"
  cr ."          300 baud, 8 data, 2 stop bits, no parity"
  cr
  cr ." Conversion utility for Kansas City Standard and CUTS"
  cr ." tapes. Input/output is an 8-bit mono WAV, VOC or RAW"
  cr ." wavefile recorded at 22,050 samples per second."
  set-io  error1 ;








\ Misc
: M+!  ( n a -- )  dup >r  2@  rot m+  r> 2! ;

\ Define n character array
-? : ARRAY  create ( n -- ) allot  does> ( n -- a ) + ;

\ Define n character string header
-? : STR  create ( n -- ) c,  does> ( -- a u ) count ;








\ Variables -
variable BITCOUNT               \ bit counter
variable CONOUT                 \ console flag
variable DECODING               \ 0=encode nz=decode
variable INVERTED               \ invert wavefile flag
variable LEADTIME               \ leader (secs)
variable MODE                   \ CUTS mode flag
variable NULLCNT                \ nulls
variable NULLCHAR               \ char preceding null
variable PACE                   \ pacing (msec)
variable PARITY                 \ parity 0=none 1=odd 2=even
variable SAMPLECOUNT            \ sample count
variable SBITS                  \ stop bits
variable SPEED                  \ speed 1=300 2=600 4=1200
variable STRICT                 \ strict decoding

\ Variables -
variable TONE                   \ tone type
variable WAVE                   \ wave type
variable IGNORE                 \ ignore errors flag
variable ERRORS                 \ decode error count

2variable DECODECOUNT           \ bytes decoded
2variable PARITYCOUNT           \ parity error count
2variable WAVESIZ               \ wavefile data size







\ Variables -
  0 value BIAS                  \ waveform DC offset adjust
  8 value DATABITS              \ character length
  3 value HYSTERESIS            \ hysteresis level
 12 value MAXWAVE               \ max sample for high tone
130 value SILENCEMAX            \ upper hysteresis level
124 value SILENCEMIN            \ lower hysteresis level

12 array BITS                   \ bit array







\ SETLEVELS WAVETYPE
\ Set waveform trigger levels
: SETLEVELS  ( -- )
  1275  hysteresis 10 *  2dup
  - 10 / bias +  0 max 255 min  to silencemin
  + 10 / bias +  0 max 255 min  to silencemax ;

\ Get default wavefile type
: WAVETYPE  ( -- a u )
  wave @  case
    0  of  s" WAV"  endof
    1  of  s" VOC"  endof
    2  of  s" RAW"  endof
  endcase ;


\ (SETOPTION)
\ Set options
: (SETOPTION)  ( a u char -- a u )
  upcase case
    [char] B  of  1 2 /numrange  2*  speed !  endof
    [char] C  of  conout on  endof
    [char] D  of  7 to databits  endof
    [char] E  of  2 parity !  endof
    [char] F  of  -127 127 /numrange to bias  setlevels  endof
    [char] G  of  -2 2 /numrange  maxwave +  to maxwave  endof
    [char] H  of  0 127 /numrange to hysteresis setlevels  endof
    [char] I  of  inverted on  endof
    [char] L  of  /num  leadtime !  endof
    [char] M  of  decoding off  endof
    [char] N  of  /num  dup 0< if  13 nullchar !  then
                  abs  nullcnt !  endof
\ (SETOPTION)
    [char] O  of  1 parity !  endof
    [char] P  of  /num  pace !  endof
    [char] R  of  2 wave !  endof
    [char] S  of  1 sbits !  endof
    [char] T  of  1 tone !  endof
    [char] U  of  mode on  endof
    [char] V  of  1 wave !  endof
    [char] X  of  strict on  endof
    [char] Y  of  ignore on  endof
    badoption
  endcase ;

' (setoption) is setoption


\ (PARSEFILENAME)
\ Parse filenames
: (PARSEFILENAME)  ( -- )
  argv  0= if  help  then
  decoding @ if  wavetype  else  s" PRG"  then
  +ext  64 min  infile place
  argv  0= if  infile count  -path -ext  then
  decoding @ if  s" PRG"  else  wavetype  then
  +ext  64 min  outfile place ;

' (parsefilename) is parsefilename





\ WAV-HDR VOC-HDR
hex
2C str WAV-HDR  ( WAV header )
52 c, 49 c, 46 c, 46 c, 00 c, 00 c, 00 c, 00 c,
57 c, 41 c, 56 c, 45 c, 66 c, 6D c, 74 c, 20 c,
10 c, 00 c, 00 c, 00 c, 01 c, 00 c, 01 c, 00 c,
22 c, 56 c, 00 c, 00 c, 22 c, 56 c, 00 c, 00 c,
01 c, 00 c, 08 c, 00 c, 64 c, 61 c, 74 c, 61 c,
00 c, 00 c, 00 c, 00 c,

20 str VOC-HDR  ( VOC header )
43 c, 72 c, 65 c, 61 c, 74 c, 69 c, 76 c, 65 c,
20 c, 56 c, 6F c, 69 c, 63 c, 65 c, 20 c, 46 c,
69 c, 6C c, 65 c, 1A c, 1A c, 00 c, 0A c, 01 c,
29 c, 11 c, 01 c, 00 c, 00 c, 00 c, D3 c, 00 c,
decimal
\ 0BIT-SQR-KCS
hex
12 str 0BIT-SQR-KCS  ( 1 cycle 1200 hz - square equalized )
( normal )
9B c, C1 c, D9 c, E8 c, F2 c, F9 c, FC c, FF c, A0 c,
64 c, 3E c, 26 c, 17 c, 0D c, 06 c, 03 c, 00 c, 5F c,
( inverted )
64 c, 3E c, 26 c, 17 c, 0D c, 06 c, 03 c, 00 c, 5F c,
9B c, C1 c, D9 c, E8 c, F2 c, F9 c, FC c, FF c, A0 c,
decimal






\ 1BIT-SQR-KCS
hex
12 str 1BIT-SQR-KCS  ( 2 cycle 2400 hz - square equalized )
( normal )
9D c, DC c, F5 c, FF c, 97 c, 55 c, 2B c, 11 c, 00 c,
9D c, DC c, F5 c, FF c, 97 c, 55 c, 2B c, 11 c, 00 c,
( inverted )
62 c, 23 c, 0A c, 00 c, 68 c, AA c, D4 c, EE c, FF c,
62 c, 23 c, 0A c, 00 c, 68 c, AA c, D4 c, EE c, FF c,
decimal






\ 0BIT-SIN-KCS
hex
12 str 0BIT-SIN-KCS  ( 1 cycle 1200 hz bit - sine )
( normal )
96 c, C0 c, E2 c, F8 c, FF c, F8 c, E2 c, C0 c, 96 c,
6A c, 40 c, 1E c, 08 c, 00 c, 08 c, 1E c, 40 c, 6A c,
( inverted )
69 c, 3F c, 1D c, 07 c, 00 c, 07 c, 1D c, 3F c, 69 c,
95 c, BF c, E1 c, F7 c, FF c, F7 c, E1 c, BF c, 95 c,
decimal






\ 1BIT-SIN-KCS
hex
12 str 1BIT-SIN-KCS  ( 2 cycle 2400 hz - sine )
( normal )
D2 c, FE c, EF c, AC c, 54 c, 11 c, 02 c, 2E c, 80 c,
D2 c, FE c, EF c, AC c, 54 c, 11 c, 02 c, 2E c, 80 c,
( inverted )
2D c, 01 c, 10 c, 53 c, AB c, EE c, FD c, D1 c, 7F c,
2D c, 01 c, 10 c, 53 c, AB c, EE c, FD c, D1 c, 7F c,
decimal






\ 0BIT-SQR-CUTS
hex
12 str 0BIT-SQR-CUTS  ( 1/2 cycle 600 hz - square equalized )
( normal )
9B c, C1 c, D9 c, E8 c, F2 c, F9 c, FC c, FF c, FF c,
FF c, FF c, FF c, FF c, FF c, FF c, FF c, FF c, FF c,
( inverted )
64 c, 3E c, 26 c, 17 c, 0D c, 06 c, 03 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
decimal






\ 1BIT-SQR-CUTS
hex
12 str 1BIT-SQR-CUTS  ( 1 cycle 1200 hz - square equalized )
( normal )
9B c, C1 c, D9 c, E8 c, F2 c, F9 c, FC c, FF c, A0 c,
64 c, 3E c, 26 c, 17 c, 0D c, 06 c, 03 c, 00 c, 5F c,
( inverted )
64 c, 3E c, 26 c, 17 c, 0D c, 06 c, 03 c, 00 c, 5F c,
9B c, C1 c, D9 c, E8 c, F2 c, F9 c, FC c, FF c, A0 c,
decimal






\ 0BIT-SIN-CUTS
hex
12 str 0BIT-SIN-CUTS  ( 1/2 cycle 600 hz bit - sine )
( normal )
96 c, AB c, BF c, D2 c, E1 c, EE c, F7 c, FD c, FF c,
FD c, F7 c, EE c, E1 c, D2 c, BF c, AB c, 96 c, 80 c,
( inverted )
69 c, 54 c, 40 c, 2E c, 1E c, 11 c, 08 c, 02 c, 00 c,
02 c, 08 c, 11 c, 1E c, 2E c, 40 c, 54 c, 69 c, 80 c,
decimal






\ 1BIT-SIN-CUTS
hex
12 str 1BIT-SIN-CUTS  ( 1 cycle 1200 hz bit - sine )
( normal )
96 c, C0 c, E2 c, F8 c, FF c, F8 c, E2 c, C0 c, 96 c,
6A c, 40 c, 1E c, 08 c, 00 c, 08 c, 1E c, 40 c, 6A c,
( inverted )
69 c, 3F c, 1D c, 07 c, 00 c, 07 c, 1D c, 3F c, 69 c,
95 c, BF c, E1 c, F7 c, FF c, F7 c, E1 c, BF c, 95 c,
decimal






\ 0BIT-SQR 1BIT-SQR 0BIT-SIN 1BIT-SIN SENDBIT
\ Bit data
defer 0BIT-SQR  ( a u -- )
defer 1BIT-SQR  ( a u -- )
defer 0BIT-SIN  ( a u -- )
defer 1BIT-SIN  ( a u -- )

\ Send a 'bit' to output
: SENDBIT  ( a u -- )
  inverted @ if    ( index to inverted bit data )
    swap over + swap  then
  4  speed @  /  ( loops needed to make one bit )
  0 do
    2dup  dup wavesiz m+!  writedata  loop
  2drop ;

\ 0BIT 1BIT
\ Send 0-bit
: 0BIT  ( -- )  tone @  case
    0  of  0bit-sqr  endof
    1  of  0bit-sin  endof
    endcase
  sendbit
  mode @ if ( toggle flag ) inverted @  0= inverted ! then ;

\ Send 1-bit
: 1BIT  ( -- )  tone @  case
    0  of  1bit-sqr  endof
    1  of  1bit-sin  endof
    endcase
  sendbit ;

\ STARTBIT STOPBITS PACING LEADER
\ Send start bit
: STARTBIT  ( -- )  0bit ;

\ Send stop bits
: STOPBITS  ( -- )
  sbits @  0 ?do  1bit  loop ;

\ Write pace (3.27 ms)
: PACING  ( -- )
  speed @  0 ?do  1bit  loop ;

\ Write leader tone
: LEADER  ( -- )
  leadtime @  306 *  0 ?do  pacing  loop ;

\ SENDBYTE NULLS
\ Send character
: SENDBYTE  ( char -- )
  startbit
  0 swap  databits 0 do
    2 /mod
    swap if  1bit  swap 1+ swap  else  0bit  then  loop
  drop  parity @ if
    1 and  parity @ + 2- if  1bit  else  0bit  then
  else  drop  then
  stopbits
  pace @  3 /  0 ?do  pacing  loop ;

\ Write nulls
: NULLS  ( -- )
  nullcnt @  0 ?do  0 sendbyte  loop ;
\ STARTWAVE !SIZE
\ Write header, leader
: STARTWAVE  ( -- )
  0. wavesiz 2!
  wave @  case
    0  of  wav-hdr writedata  endof
    1  of  voc-hdr writedata  endof
    endcase
  leader ;

\ Patch WAV/VOC data size
: !SIZE  ( u -- )
  wavesiz 2@  swap  pad 2!  pad swap writedata ;



\ ENDWAVE
\ Write leader, patch in size
: ENDWAVE  ( -- )
  leader
  wave @  case
    0  of  0 pad c!  pad 1 writedata
           40. outfid @  reposf  4 !size
           4.  outfid @  reposf
           36 wavesiz m+!  4 !size  endof
    1  of  0 pad c!  pad 1 writedata
           27. outfid @  reposf
           2  wavesiz m+!  3 !size  endof
    endcase ;



\ ENCODE
\ Convert program file to wave
: ENCODE  ( -- )
  startwave
  begin
    readchar
  while ( not end )
    dup sendbyte
    nullchar @ = if nulls then
  repeat
  endwave ;





\ .DECODED
\ Display number of decoded bytes
: .DECODED  ( -- )
  decodecount 2@  cr ud. ." bytes decoded"
  parity @ if
    ." , "  paritycount 2@  ud. ." parity errors"
  then
  ignore @ if
    ." , "  errors @  u. ." decode errors"
  then ;






\ ?ERROR .POSITION BADPATTERN MISSING
\ Increment decode error count
: ?ERROR  ( -- )  errors @  $FFFF  u< if  1 errors +!  then
  ignore @  2 ?throw ;

\ Show position at which error occured
: .POSITION  ( -- )  ."  at position "  infilepos ud.
  .decoded  error2 ;

\ Bad pattern error
: BADPATTERN  ( -- )  ?error  cr ." Bad pattern" .position ;

\ Item missing error
: MISSING  ( a u -- )  ?error  cr ." Missing " type .position ;


\ SAMPLE
\ Get sample
: SAMPLE  ( -- char )
  readchar 0= 1 ?throw  1 samplecount +! ;












\ SEEK+
\ Seek +ve going edge
0 [if]
: SEEK+  ( -- )  begin  sample  silencemax >  until ;
[else]
code SEEK+  ( -- )
1 $:  0 # insiz ) cmp  2 $ jnz
    c: refillread  insiz @  0= 1 ?throw ;c
2 $:  inptr ) di mov  0 [di] al mov
  inptr ) inc  insiz ) dec  samplecount ) inc
  ' silencemax >body ) al cmp  1 $ jna
  next
end-code
[then]


\ SEEK-
\ Seek -ve going edge
0 [if]
: SEEK-  ( -- )  begin  sample  silencemin <  until ;
[else]
code SEEK-  ( -- )
1 $:  0 # insiz ) cmp  2 $ jnz
    c: refillread  insiz @  0= 1 ?throw ;c
2 $:  inptr ) di mov  0 [di] al mov
  inptr ) inc  insiz ) dec  samplecount ) inc
  ' silencemin >body ) al cmp  1 $ jnb
  next
end-code
[then]


\ SEEKHALF
\ Seek half cycle
: SEEKHALF  ( -- samples )
  samplecount off
  inverted @ if  seek+  else  seek-  then
  samplecount @  inverted @  0=  inverted ! ;










\ SEEKWHOLE HIGH? LOWHALF?
\ Seek whole cycle
: SEEKWHOLE  ( -- samples )
  seekhalf seekhalf + ;

\ Test last cycle, true if high tone
: HIGH?  ( samples -- flag )
  maxwave > not ;

\ Test last half cycle, true if low tone
: LOWHALF?  ( samples -- flag )
  maxwave 2/ > ;




\ #CYCLES SEEKSTART-KCS
\ Number of cycles in a '1' bit
: #CYCLES  ( -- n )
  8  speed @  / ;

\ Seek start bit
: SEEKSTART-KCS  ( -- )
  #cycles  ( half cycles in a '0' bit )
  begin
    seekhalf lowhalf?
    if  1-  else  drop  #cycles  then
    ?dup 0=
  until ;



\ NEXTCYCLE GETBIT-KCS
\ Get next cycle, return true if high tone
: NEXTCYCLE  ( -- flag )
  seekwhole high? ;

\ Get next bit
: GETBIT-KCS  ( -- bit )
  nextcycle  ( get first cycle )
  #cycles  over 0= if  2/  then  ( get remaining )
  begin
    1- ?dup
  while
    over  nextcycle - if  badpattern  then
  repeat
  negate ;

\ SEEKSTART-CUTS GETBIT-CUTS
\ Seek start bit
: SEEKSTART-CUTS  ( -- )
  begin
    seekhalf high? not
  until ;

\ Get next bit
: GETBIT-CUTS  ( -- bit )
  seekhalf high?
  dup  if ( get second half cycle )
    seekhalf high? not if  badpattern  then
  then
  negate ;


\ #BITS SAVEBIT
\ Number of bits in the character to get
: #BITS  ( -- n )
  databits  parity @ if  1+  then  ( parity )
  strict @ if  sbits @ +  then  ( stop ) ;

\ Save bit
: SAVEBIT  ( bit -- )
  bitcount @ bits c!  ( save to bit array )
  1 bitcount +! ;     ( inc bit count )






\ SEEKSTART GETBIT GETBITS
\ Seek start bit
defer SEEKSTART  ( -- )

\ Get next bit
defer GETBIT  ( -- bit )

\ Get start, data, parity and stop bits
: GETBITS  ( -- )
  bitcount off
  seekstart  0 savebit  ( startbit )
  #bits 0 do  ( remaining bits )
    getbit  savebit
  loop ;


\ ?STARTBIT ?STOPBIT
\ Test startbit
: ?STARTBIT  ( -- )
  0 bits c@ if  s" startbit"  missing  then ;

\ Test stopbits
: ?STOPBIT  ( -- )
  strict @ if
    1 databits +  parity @ if  1+  then
    sbits @  0 do
      dup bits c@ 1- if  s" stopbit"  missing  then
      1+
    loop  drop
  then ;


\ ?PARITYBIT FORMBYTE
\ Test parity bit
: ?PARITYBIT  ( -- )
  parity @ if
    0  databits 2+  1 do  i bits c@ +  loop
    1 and  parity @ +  2- if  1 paritycount m+!  then
  then ;

\ Form byte from received bits
: FORMBYTE  ( -- byt )
  ?startbit ?stopbit ?paritybit
  0  databits 1+  1 do
    i bits c@  i 1- lshift  or
  loop ;


\ DECODEBYTE SKIPHEADER
\ Decode next byte
: (DECODEBYTE)  ( -- byt )  getbits formbyte ;

\ Decode next byte, ignoring errors
: DECODEBYTE  ( -- byt )
  begin
    [']  (decodebyte)  2 ?catch 0= if  exit  then
  again ;

\ Skip any header
: SKIPHEADER  ( -- )
  64 0 do
    readchar if  drop  else  leave  then
  loop ;

\ DECODE
\ Convert wave file to program
: DECODE  ( -- )
  0. decodecount 2!  0. paritycount 2!  0 errors !
  skipheader
  begin
    ['] decodebyte  1 ?catch 0=
  while ( not EOF )
    conout @ if  emit  else  writechar  then
    1 decodecount m+!
  repeat
  .decoded ;




\ SETMODE
\ Select Kansas City Standard or Processor Tech. CUTS mode
: SETMODE  ( -- )
  mode @ if ( CUTS )
    8 to databits  2 sbits !  4 speed !  parity off  pace off
    nullcnt off
    ['] 0bit-sqr-cuts is 0bit-sqr  ['] 1bit-sqr-cuts is 1bit-sqr
    ['] 0bit-sin-cuts is 0bit-sin  ['] 1bit-sin-cuts is 1bit-sin
    ['] seekstart-cuts is seekstart  ['] getbit-cuts is getbit
  else ( KCS )
    ['] 0bit-sqr-kcs is 0bit-sqr  ['] 1bit-sqr-kcs is 1bit-sqr
    ['] 0bit-sin-kcs is 0bit-sin  ['] 1bit-sin-kcs is 1bit-sin
    ['] seekstart-kcs is seekstart  ['] getbit-kcs is getbit
  then ;


\ (RUN)
\ Run application
: (RUN)  ( -- )
  setmode
  r/o openinfile
  decoding @ if
    conout @ 0= if  r/w makeoutfile  then
    cr decode
  else
    r/w makeoutfile
    cr encode
  then
  closefiles
  ;


\ DEFAULTS
\ Set application defaults
: DEFAULTS  ( -- )
  mode off  decoding on  strict off  ignore off  conout off
  1 speed !  2 sbits !  parity off  5 leadtime !  10 nullchar !
  pace off  nullcnt off  wave off  tone off  inverted off ;

defaults








\ RUN PROGRAM
\ Run application with error handling
: RUN  ( -- )
  ['] (run) catch ?dup if  >r errfix r> throw  then ;

\ Main
: PROGRAM  ( -- )
  set-io                \ set console mode
  defaults              \ set defaults
  cr title              \ show application name
  parsecmd              \ get options/filenames
  run                   \ run application
  cr ." done"           \ show success
  ;