program sircsall;



{

************************************************************



SIRCS - Serial Infrared Remote Control System (Ver. 4)



Original Software written by:

Heiko Purnhagen   27-nov-95, 30-jun-96, 19-aug-96, 08-sep-96

e-mail: purnhage@tnt.uni-hannover.de

WWW:    http://www.fet.uni-hannover.de/purnhage/



Modified by sircs 30-May-1998

email: sircs@Geocities.com

www:    http://www.geocities.com/capecanaveral/launchpad/4652

This program now read all versions of the sircs commands

ie: 12bit, 15bit & 20bit.



This program may be copied according to the GNU General Public Licence.





Changes:



SIRCS    27-nov-95   first version

SIRCS2   30-jun-96   improved handling of auto-repeat keys

                     added non-verbose version of "transmit sony msgs"

SIRCS3   19-aug-96   added command line options

                     added cli/sti and timing check

SIRCS4   08-sep-96   added 38.4 kHz carrier generation to drive

                     an IR-LED directly from TD

SIRCSALL 30-may-98   changed to read and send 12bit, 15bit &20bit commands




About this program

------------------



This program is written in Turbo Pascal 6.0 and requires a reasonable

fast PC (486SX 25 MHz or even 386DX 6 MHz is sufficient). Since

direct access to the PC hardware is employed, this program must be started

directly from DOS (and not from a DOS-Window within MS-Windows).



In order to be able to receive and transmit (infrared) remote control

signals, you have to connect an appropriate interface to the serial

port of your PC. This interface either containes an infrared LED and/or

photodiode to transmit and/or receive the infrared remote control signal

or it is connected directly to the device to be controlled.



A typical infrared transmitter generates a 40 kHz carrier which is

switched on and off according to the serial remote control signal

and then transmitted by the LED.



A typical infrared receiver contains a circuit that detects whether

or not the photodiode is receiving a 40 kHz carrier.



A typical direct interface has to convert (or just limit) the

logical levels of the serial remote control signal to those required

by the device to be controlled.



The different signals of the serial interface connector are used in

a slightly odd way here:



SG       ground

CTS      signal from receiver

RTS      signal to transmitter/device

DTR      positive voltage providing some power for interface circuits

TD       normal mode: positive voltage (as "DTR")

         LED mode:    transmit signal (with 38.4 kHz carrier)





Serial Interface Connector

--------------------------



D25  D9  in/out  signal



  1   -     -    FG   Frame Ground

  2   3     O    TD   Transmit Data

  3   2     I    RD   Receive Data

  4   7     O    RTS  Request to Send

  5   8     I    CTS  Clear to Send

  6   6     I    DSR  Data Set Ready

  7   5     -    SG   Signal Ground

  8   1     I    DCD  Data Carrier Detected

 20   4     O    DTR  Data Terminal Ready

 22   9     I    RI   Ring Indicator



 +3V..+12V = active   = space = 0

 -3V..-12V = inactive = mark  = 1





A simple interface for Sony DAT TCD-D7 / TCD-D8

------------------------------------------------



Note: The D7 requires a low-active serial remote control signal !!!



PC serial (D9)                        D7 / D8 connector

                 10kOhm    10kOhm

RTS (pin 7)   o---RRR---+---RRR---o   sircs (pin 7)      1 2 3 4

                        |                              +---------+

                        K z-diode                      | o o o o |

                        A ZPD 4.3V                     | o o o  /

                        |                              +--------

SG  (pin 5)   o---------+---------o   ground (pin 6)     5 6 7



For further information about the D7 connector, have a look at

http://www.fet.uni-hannover.de/purnhage/dat/dat.html





An optocoupler-based interface for Sony DAT TCD-D7 / TCD-D8

------------------------------------------------------------



Note: This interface is inverting, so you have to feed it

      with an high-active SIRCS signal !!!



                                                D8 connector



                                 +-----------o  # 2  +4V/+5V

                                 |

                                 |

                                 R 10 kOhm

                                 R

PC serial (D25)                  |

                 470 Ohm         |

RTS (pin 4)   o---RRR------+     +-----------o  # 7  sircs

                       pin1|     |pin5

                           |     |

                           A ->  C

                           K ->  E

                           |     |

                           |     |

SG  (pin 7)   o------------+     +-----------o  # 6  ground

                        pin2     pin4

                            CNY17

                          or similar



This interface was designed by Ulrich Hornstein <u.hornstein@t-online.de>.

His original description is also available on

http://www.fet.uni-hannover.de/purnhage/dat/dat.html





Connecting an IR receiver module

--------------------------------



There is a cheap ( < 5 US$ ) IR receiver module available from

"Conrad Electronic" (Nr. 177695). It requires a few mA power at 5 V and has a

low-active output. It can be connected directly to a TCD-D7 / TCD-D8.

To connect it to the PC's serial port (for usage with SIRCS), an additional

5 V power source / voltage regulator and a 4.7 kOhm pull-up resistor is

required.





Driving an IR-LED directly from TD

----------------------------------



It is also possible to connect an IR-LED directly to the TD pin of the PC's

serial port to transmit SIRCS messages with an 38.4 kHz carrier signal.



        470 Ohm

  TD  o---RR---+

               |

               A  IR

               K  LED

               |

  SG  o--------+





Sony serial remote control signal format

----------------------------------------



A message contains 12 bits and is transmitted every 45 ms (22.2 times

per second) as long as the key on the remote control is held down. A

message is transmitted at least 3 times.



The signal for the message "pause" for a Sony DAT recorder is



......XXXX.XX.X.X.XX.XX.XX.X.X.X.XX.XX.XX......



where X means an active signal (40kHz carrier transmitted by infrared

remote control) and . means no signal. Each X or . has a duration

of 0.6 ms. The message consists of a start pulse (2.4 ms) which is

followed by 12 data pulses (0.6 ms or 1.2 ms). Each pulse is followed

by a 0.6 ms pause. A 0.6 ms data pulse means a "0", a 1.2 ms pulse a "1".



This program can store such messages in a file, one message per line.

The DAT "pause" message shown above can be stored as



100111000111:pause


For a complete list of commands look at:

http://www.geocities.com/capecanaveral/launchpad/4652



************************************************************

}







{ declarations }



{$n-}

{$e-}

{$d-}

{$l-}



uses

  crt, graph;



const

             { 16550 registers }

  rbr = 0;   { receiver buffer (read) }

  thr = 0;   { transmitter hold (write) }

  ier = 1;   { interrupt enable }

  iir = 2;   { interrupt identification (read) }

  fcr = 2;   { fifo control (write) }

  lcr = 3;   { line control }

  mcr = 4;   { modem control }

  lsr = 5;   { line status }

  msr = 6;   { modem status }

  scr = 7;   { scratch }

  dll = 0;   { divisor latch (lsb) }

  dlm = 1;   { divisor latch (msb) }



  clkfreq = 1.19318e6;   { pit 8253 cntr 0 clock freq. }

  msgsize = 201;



type

  wordptr = ^word;

  msgt = array[1..msgsize] of word;   { basic message, 0 = msg end }

  smsgt = array[1..20] of byte;   { maximum sony message }



var

  base, mcrbuf,bits : word;

  invrx, invtx : byte;

  clkbufl, clkbufh : word;

  c : char;

  b : boolean;

  readkeylast : char;

  err : integer;

  com,rpt : integer;

  fns : string;

  yn : string;

  tmg : real;





{ serial interface }



function initio (com : integer) : boolean;

{ ok -> true }

var

  b : byte;

  l : longint;

begin

  initio := false;

  if (com < 1) or (com > 4) then

    exit;

  base := wordptr(ptr($0040,2*(com-1)))^;

  if base = 0 then

    exit;

  initio := true;

  mcrbuf := (port[base+mcr] or $01) and $fd;   { set DTR, reset RTS }

  port[base+mcr] := mcrbuf or (((b xor invtx) and 1) shl 1);

  if invtx >= 2 then

  begin

    b := 2;   { 7N1 }

    l := 1;   { 115200 baud }

    port[base+lcr] := $80;   { dlab = 1 }

    port[base+dll] := lo(word(l));

    port[base+dlm] := hi(word(l));

    port[base+lcr] := b;

    port[base+ier] := 0;   { no interrupts }

    port[base+fcr] := 0;   { fifo disabled }

  end

  else

    port[base+lcr] := port[base+lcr] or $40;   { set TD }

end;



procedure restoreio;

begin

  if base = 0 then

    exit;

  port[base+mcr] := mcrbuf and $fc;   { reset DTR, RTS }

  port[base+lcr] := port[base+lcr] and $bf;   { reset TD }

end;



function getrx : byte;

begin

  getrx := ((port[base+msr] and $10) shr 4) xor invrx;

end;



procedure puttx (b : byte);

begin

  port[base+mcr] := mcrbuf or (((b xor invtx) and 1) shl 1);

end;



procedure gen38k;

begin

  repeat

  until (port[base+lsr] and $20) = $20;

  port[base+thr] := $12;   { start= 0 0100100 1 =stop   0=+12V=LED on }

end;





{ timer (pit 8253 cntr 0 clk 1.19318 MHz) }



procedure initclk;

begin

  port[$0043] := $34;   { cntr 0: mode 2 16bit }

  port[$0040] := $00;

  port[$0040] := $00;

end;



procedure resetclk;

begin

  clkbufl := 0;

  clkbufh := 0;

end;



function getclk : longint;

  var

    t : word;

begin

  port[$0043] := $00;   { cntr 0: latch }

  t := port[$0040];

  t := not(t+(port[$0040] shl 8));

  if t < clkbufl then

    inc(clkbufh);

  clkbufl := t;

  getclk := clkbufl+(longint(clkbufh) shl 16);

end;





{ check system timing }



function clkmax : real;

  var

    t0,t1,dt,max,tm : longint;

    i : integer;

    b : byte;

begin

  resetclk;

  tm := round(0.5 * clkfreq);

  max := 0;

  asm

    cli;

  end;

  t1 := getclk;

  tm := tm + t1;

  repeat

    b := getrx;

    t0 := t1;

    t1 := getclk;

    dt := t1-t0;

    if dt > max then

      max := dt;

  until t1 > tm;

  asm

    sti;

  end;

  clkmax := max / clkfreq;

end;





{ basic message i/o }



function getmsg (var msg : msgt; minbit, maxbit : word; timeout : longint;

                 keybreak : boolean) : longint;

{ error -> -1   timeout -> 0   ok -> time before start bit }

  var

    t,t0,tt,tb,tw : longint;

    b,b0 : byte;

    idx : byte;

begin

  asm

    cli;

  end;

  getmsg := -1;

  idx := 1;

  msg[idx] := 0;

  resetclk;

  t := getclk;

  b := getrx;

  tt := t+timeout;

  repeat

    t0 := t;

    tb := t0+maxbit;

    while b > 0 do

    begin

      t := getclk;

      b := getrx;

      if t > tb then

      begin

        asm

          sti;

        end;

        exit;

      end;

    end;

    t0 := t;

    while b = 0 do

    begin

      t := getclk;

      b := getrx;

      if t > tt then

      begin

        getmsg := 0;

        asm

          sti;

        end;

        exit;

      end;

      if keybreak and keypressed then

      begin

        asm

          sti;

        end;

        exit;

      end;

    end;

  until t > t0+maxbit;

  tw := t-t0;

  repeat

    t0 := t;

    tb := t0+maxbit;

    while b > 0 do

    begin

      t := getclk;

      b := getrx;

      if t > tb then

      begin

        asm

          sti;

        end;

        exit;

      end;

    end;

    if t-t0 < minbit then

    begin

      asm

        sti;

      end;

      exit;

    end;

    msg[idx] := t-t0;

    inc(idx);

    msg[idx] := 0;

    t0 := t;

    tb := t0+maxbit;

    while (b = 0) and (t <= tb) do

    begin

      t := getclk;

      b := getrx;

      if t > tt then

      begin

        asm

          sti;

        end;

        exit;

      end;

    end;

    if t-t0 < minbit then

    begin

      asm

        sti;

      end;

      exit;

    end;

    if t > tb then

    begin

      getmsg := tw;

      asm

        sti;

      end;

      exit;

    end;

    msg[idx] := t-t0;

    inc(idx);

    msg[idx] := 0;

  until idx = msgsize;

  asm

    sti;

  end;

end;



procedure putmsg (msg : msgt; wait : longint);

  const

    gen38time = 93;   { 1.19318 MHz / 115.2 kbit/s * 9 bit }

  var

    t,t0 : longint;

    idx,i,n : integer;

begin

  asm

    cli;

  end;

  idx := 1;

  resetclk;

  t := getclk;

  t0 := t;

  while msg[idx] > 0 do

  begin

    puttx (idx and 1);

    if (invtx >= 2) and ((idx and 1) = 1) then

    begin

      n := (msg[idx]+gen38time div 2) div gen38time;

      for i := 1 to n do

        gen38k;

    end;

    t0 := t0+msg[idx];

    repeat

      t := getclk

    until t > t0;

    inc(idx);

  end;

  puttx(0);

  t0 := t0+wait;

  repeat

    t := getclk

  until t > t0;

  asm

    sti;

  end;

end;





{ sony message codec }



function decsmsg (msg : msgt; var smsg : smsgt; var maxdev : real) : boolean;

{ ok -> true }

  const

    dt = 0.0006;

  var

    i : integer;



  procedure checkdev (dev : real);

  begin

    if dev < 0 then

      dev := -dev;

    if maxdev < dev then

      maxdev := dev;

  end;



begin

  maxdev := 0;

  i := 1;

  while msg[i] > 0 do

    inc(i);

  decsmsg := false;

  if i <> ((bits*2)+2) then

    exit;

  decsmsg := true;

  checkdev (msg[1]/clkfreq-4*dt);

  for i := 1 to bits do

  begin

    checkdev (msg[2*i]/clkfreq-dt);

    smsg[i] := 0;

    if msg[2*i+1]/clkfreq > 1.5*dt then

      smsg[i] := 1;

    checkdev (msg[2*i+1]/clkfreq-(1+smsg[i])*dt);

  end;

  maxdev := maxdev/dt;

  if maxdev > 0.4 then

    decsmsg := false;

end;



procedure encsmsg (smsg : smsgt; var msg : msgt; var wait : longint);

  const

    dt = 0.0006;

  var

    i : integer;

begin

  wait := round(0.045*clkfreq);

  msg[1] := round(4*dt*clkfreq);

  wait := wait - msg[1];

  for i := 1 to bits do

  begin

    msg[2*i] := round(dt*clkfreq);

    msg[2*i+1] := round((1+smsg[i])*dt*clkfreq);

    wait := wait - msg[2*i];

    wait := wait - msg[2*i+1];

  end;

  msg[((bits*2)+2)] := 0;

end;





{ readkey for autorepeat }



function readkeyrepeat : char;

  var

    c : char;

begin

  if not keypressed then

    c := readkey

  else

    repeat

      c := readkey;

    until (not keypressed) or (c <> readkeylast);

  readkeylast := c;

  readkeyrepeat := c;

end;





{ basic test functions }



procedure testtext;

  var

    s : string;

begin

  s := '.1';

  repeat

    write(s[getrx+1]);

  until keypressed;

  writeln;

  write ('press <ret>');

  readln;

end;



procedure testgraph;

  var

    gd,gm : integer;

    x,y,xx,yy,cc : integer;

    s,ss : string;

begin

  gd := Detect;

  write ('bgi path (\tp\bgi) ?');

  readln (s);

  if s = '' then

    s := '\tp\bgi';

  write ('att400 (y/n) ? ');

  readln (ss);

  if ss = 'y' then

  begin

    gd := att400;

    gm := att400hi;

  end;

  InitGraph(gd,gm,s);

  if GraphResult <> grOk then

  begin

    writeln ('graph error');

    exit;

  end;

  xx := getmaxx;

  yy := getmaxy;

  cc := getmaxcolor;

  repeat

    for y := 0 to yy do

    begin

      for x := 0 to xx do

        putpixel (x,y,getrx*cc);

      if keypressed then

      begin

        closegraph;

        write ('press <ret>');

        readln;

        exit;

      end;

    end;

  until false;

end;



procedure testtime;

  var

    msg : array[1..10] of msgt;

    p : array[1..10] of longint;

    idx : integer;

    b,bb,i : integer;

    t,tt,maxt : longint;

    s : string;

begin

  writeln ('press any key to transmit last 5 messages');

  s := '\/';

  repeat

    for idx := 1 to 5 do

    begin

      p[idx] := getmsg(msg[idx],round(clkfreq*0.0001),round(clkfreq*0.020),

                       round(clkfreq*1.000),true);

      if p[idx] = -1 then

        writeln ('error')

      else if p[idx] = 0 then

        writeln ('timeout')

      else

      begin

        i := 1;

        while msg[idx][i] > 0 do

        begin

          write (s[1+(i and 1)],msg[idx][i]/clkfreq*1000:7:2);

          inc(i);

        end;

        if i > 1 then

          writeln;

        writeln (i div 2,' bits   ',0.020+p[idx]/clkfreq:9:6,' s pause');

      end;

    end;

  until keypressed;

  writeln ('press <ret> to start transmitting');

  readln;

  writeln ('press any key to quit');

  repeat

    for idx := 1 to 5 do

    begin

      if p[idx] > 0 then

      begin

        write (idx);

        putmsg (msg[idx],p[idx]);

      end;

    end;

  until keypressed;

  writeln;

  writeln ('press <ret>');

  readln;

end;





{ save basic message to file }



procedure timetofile;

  const

    maxmsg = 20;

  var

    msg : array[1..maxmsg] of msgt;

    p : array[1..maxmsg] of longint;

    i,n,idx,nn : integer;

    fn : string;

    f : text;

    s,ss : string;

    c : char;

begin

  write ('filename ? ');

  readln (fn);

  {$i-}

  assign (f,fn);

  rewrite (f);

  {$i+}

  if ioresult <> 0 then

  begin

    writeln ('file error');

    exit;

  end;

  write ('device name ? ');

  readln (s);

  writeln (f,'.device');

  writeln (f,s);

  repeat

    repeat

      write ('key name (<ret> to quit) ? ');

      readln (s);

      ss := 'y';

      if s = '' then

      begin

        write ('quit (y/n) ? ');

        readln (ss);

      end;

    until ss = 'y';

    if s <> '' then

    begin

      writeln ('<spc> to view, <ret> to write&quit, w to write, others to restart');

      repeat

        write ('receiving... ');

        idx := 1;

        repeat

          repeat

            p[idx] := getmsg(msg[idx],round(clkfreq*0.0001),round(clkfreq*0.020),

                             round(clkfreq*1.000),true);

          until keypressed or (p[idx] > 0);

          if p[idx] > 0 then

          begin

            n := 1;

            while msg[idx][n] > 0 do

              inc(n);

            write (n div 2,'bit ');

            inc(idx);

          end;

        until keypressed or (idx = maxmsg+1);

        nn := idx-1;

        if not keypressed then

          write ('<key>');

        writeln;

        repeat

          c := readkey;

          if c = ' ' then

          begin

            ss := '\/';

            for idx := 1 to nn do

            begin

              write (0.020+(p[idx]/clkfreq):8:6,' pause   ');

              n := 1;

              while msg[idx][n] > 0 do

                inc(n);

              writeln (n div 2,' bits');

              for i := 1 to n do

                write (ss[1+(i and 1)],msg[idx][i]/clkfreq:7:5);

              writeln;

            end;

            writeln (nn,' messages');

            writeln ('<spc> to view, <ret> to write&quit, w to write, others to restart');

          end;

        until c <> ' ';

        if (c = #13) or (c = 'w') then

        begin

          writeln (f,'.button');

          writeln (f,s);

          for idx := 1 to nn do

          begin

            writeln (f,'.pause');

            writeln (f,0.020+(p[idx]/clkfreq):8:6);

            n := 1;

            while msg[idx][n] > 0 do

              inc(n);

            writeln (f,'.bits');

            writeln (f,n div 2);

            for i := 1 to n do

              writeln (f,msg[idx][i]/clkfreq:8:6);

          end;

          writeln (nn,' messages written');

        end;

      until c = #13;

    end;

  until s = '';

  close (f);

end;





{ sony message functions }



procedure testsony;

  var

    msg : msgt;

    p : longint;

    smsg : array[0..1] of smsgt;

    i,ii : integer;

    maxdev : real;

    b : boolean;

    c : char;

begin

  writeln ('format: message_bits (rel. timing deviation)');

  writeln ('        (d.ddd)=wrong timing   e=error   .=timeout');

  writeln ('transmit last message: <spc>=3*tx 1=1*tx .. 9=9*tx');

  writeln ('q=quit');

  for i := 1 to bits do

    smsg[1][i] := 0;

  c := ' ';

  repeat

    p := getmsg(msg,round(0.0003*clkfreq),round(0.003*clkfreq),

                round(1*clkfreq),true);

    if p < 0 then

      write ('e')

    else if p = 0 then

      write ('.')

    else

    begin

      if decsmsg (msg,smsg[0],maxdev) then

      begin

        b := true;

        for i := 1 to bits do

          b := b and (smsg[0][i] = smsg[1][i]);

        if not b then

        begin

          writeln;

          for i := 1 to bits do

          begin

            write (smsg[0][i]:1);

            smsg[1][i] := smsg[0][i];

          end;

        end;

        write ('(',maxdev:5:3,')');

      end

      else

        write ('(d.ddd)');

    end;

    if keypressed then

      c := readkey

    else

      c := #0;

    ii := 0;

    if c = ' ' then

      ii := 3;

    if (c >= '1') and (c <= '9') then

      ii := ord(c)-ord('0');

    if ii > 0 then

    begin

      encsmsg(smsg[1],msg,p);

      for i := 1 to ii do

      begin

        putmsg(msg,p);

        write ('T');

      end;

    end;

  until c = 'q';

  writeln;

end;





procedure savesony;

  var

    msg : msgt;

    p : longint;

    smsg : array[0..1] of smsgt;

    s : string;

    cnt : integer;

    i : integer;

    maxdev : real;

    b : boolean;

    c : char;

    fn : string;

    f : text;

begin

  write ('filename ? ');

  readln (fn);

  {$i-}

  assign (f,fn);

  rewrite (f);

  {$i+}

  if ioresult <> 0 then

  begin

    writeln ('file error');

    exit;

  end;

  write ('device ? ');

  readln (s);

  writeln (f,s);

  cnt := 0;

  repeat

    repeat

      write ('key (<ret> to quit) ? ');

      readln (s);

      if s = '' then

      begin

        repeat

          write ('quit (y/n) ? ');

          readln (c);

        until (c = 'n') or (c = 'y');

      end

      else

        c := 'y';

    until c = 'y';

    if s <> '' then

    begin

      repeat

        repeat

          write ('receiving... ');

          repeat

            repeat

              p := getmsg (msg,round(0.0003*clkfreq),round(0.003*clkfreq),

                           round(1*clkfreq),true);

              if p < 0 then

                write ('e');

            until (p > 0) or keypressed;

            if not keypressed then

            begin

              b := decsmsg (msg,smsg[0],maxdev);

              if not b then

                write ('d');

            end;

          until b or keypressed;

          if not keypressed then

          begin

            write ('(',maxdev:5:3,')');

            repeat

              repeat

                p := getmsg (msg,round(0.0003*clkfreq),round(0.003*clkfreq),

                             round(1*clkfreq),true);

                if p < 0 then

                  write ('e');

              until (p >= 0) or keypressed;

              if (p > 0) and not keypressed then

              begin

                b := decsmsg (msg,smsg[1],maxdev);

                if not b then

                  write ('d');

              end;

            until b or (p = 0) or keypressed;

            if not keypressed then

            begin

              if p = 0 then

              begin

                writeln (' timeout');

                b := false;

              end

              else

              begin

                write ('(',maxdev:5:3,')');

                b := true;

                for i := 1 to bits do

                  b := b and (smsg[0][i] = smsg[1][i]);

                if not b then

                  writeln (' error');

              end;

            end;

          end;

          if keypressed then

          begin

            writeln (' interupted');

            c := readkey;

            b := false;

          end;

          c := #0;

          if not b then

          begin

            write ('   a=abort other=retry ? ');

            c := readkey;

            writeln;

            if c <> 'a'then

              c := #0;

          end;

        until b or (c = 'a');

        if b then

        begin

          writeln;

          write ('got ');

          for i := 1 to bits do

            write (smsg[0][i]:1);

          write ('   a=abort <ret>=save other=retry ? ');

          c := readkey;

          writeln;

        end;

      until (c = 'a') or (c = #13);

      if c = #13 then

      begin

        for i := 1 to bits do

          write (f,smsg[0][i]:1);

        writeln (f,':',s);

        write ('saving ');

        for i := 1 to bits do

          write (smsg[0][i]:1);

        writeln (':',s);

        inc (cnt);

      end;

    end;

  until s = '';

  close (f);

  writeln (cnt,' keys saved');

end;



procedure playsony (verbose : boolean; fns : string; rpt : integer);

  const

    maxkey = 100;

  var

    fn,dev,s : string;

    f : text;

    cnt,i,j,n : integer;

    c : char;

    p : longint;

    msg : msgt;

    keyc : array[1..maxkey] of char;

    keyname : array[1..maxkey] of string[20];

    keysmsg : array[1..maxkey] of smsgt;

begin

  if rpt = 0 then

  begin

    write ('filename ? ');

    readln (fn);

  end

  else

    fn := fns;

  {$i-}

  assign (f,fn);

  reset (f);

  {$i+}

  if ioresult <> 0 then

  begin

    writeln ('file error');

    exit;

  end;

  readln (f,dev);

  writeln ('device = ',dev);

  cnt := 0;

  while not eof(f) do

  begin

    readln (f,s);

    if cnt=maxkey then

    begin

      writeln ('file too long');

      exit;

    end;

    if length(s) < (bits+2) then

    begin

      writeln ('file format error');

      exit;

    end;

    inc(cnt);

    for i := 1 to bits do

    begin

      if s[i] = '0' then

        keysmsg[cnt][i] := 0

      else if s[i] = '1' then

        keysmsg[cnt][i] := 1

      else

      begin

        writeln ('file format error');

        exit;

      end;

    end;

    if s[bits+1] <> ':' then

    begin

      writeln ('file format error');

      exit;

    end;

    keyname[cnt] := copy(s,(bits+2),length(s)-(bits+1));

  end;

  close(f);

  writeln (cnt,' keys loaded');

  if cnt = 0 then

    exit;

  c := 'a';

  for i := 1 to cnt do

  begin

    keyc[i] := #0;

    for j := 0 to 9 do

      if keyname[i] = chr(ord('0')+j) then

        keyc[i] := chr(ord('0')+j);

    if keyname[i] = '10' then

      keyc[i] := '0';

    if keyc[i] = #0 then

    begin

      keyc[i] := c;

      if c = 'z' then

        c := 'A'

      else

        c := chr(ord(c)+1);

    end;

  end;

  repeat

    if rpt = 0 then

    begin

      write ('number of message transmissions (typ. 3) (0=quit) ? ');

      readln (n);

    end

    else

      n := rpt;

    if n > 0 then

    begin

      writeln;

      for i := 1 to cnt do

      begin

        s := copy(keyname[i],1,16);

        write (keyc[i],':',s,'':16-length(s));

        if i mod 4 = 0 then

          writeln

        else

          write ('  ');

      end;

      writeln;

      writeln ('<ret> to quit');

      if not verbose then

        write ('?');

      repeat

        if not verbose then

          write (#8,' ',#8);

        c := readkeyrepeat;

        i := 1;

        while (i <= cnt) and (keyc[i] <> c) do

          inc (i);

        if keyc[i] = c then

        begin

          encsmsg (keysmsg[i],msg,p);

          if not verbose then

            write (c);

          for j := 1 to n do

          begin

            putmsg (msg,p);

            if verbose then

              write (c);

          end;

        end

        else

          write ('?');

      until c = #13;

      writeln;

    end;

    if rpt > 0 then

      n := 0;

  until n = 0;

end;



procedure trysony;

  var

    msg : msgt;

    p : longint;

    smsg,mask : smsgt;

    s : string;

    cnt : integer;

    i : integer;

    c : char;

    b : boolean;

    fn : string;

    f : text;

begin

  write ('filename ? ');

  readln (fn);

  {$i-}

  assign (f,fn);

  rewrite (f);

  {$i+}

  if ioresult <> 0 then

  begin

    writeln ('file error');

    exit;

  end;

  write ('device ? ');

  readln (s);

  writeln (f,s);

  writeln ('pattern: 0=0 1=1 x,X=variable (start value x=0, X=1)');

  cnt := 0;

  for i := 1 to bits do

  begin

    smsg[i] := 0;

    mask[i] := 1;

  end;

  repeat

    repeat
      if bits=12 then s := '123456789012';

      if bits=15 then s := '123456789012345';

      if bits=20 then s := '12345678901234567890';

      for i := 1 to bits do

        if mask[i] = 1 then

          s[i] := chr(ord('x')-(ord('x')-ord('X'))*smsg[i])

        else

          s[i] := chr(ord('0')+smsg[i]);

      write ('pattern (',s,') (<ret>=cont) ? ');

      readln (s);

      if s = ''then

        b := true

      else

      begin

        b := (length(s) = bits);

        for i := 1 to bits do

          if s[i] = '0' then

          begin

           smsg[i] := 0;

           mask[i] := 0;

          end

          else if s[i] = '1' then

          begin

           smsg[i] := 1;

           mask[i] := 0;

          end

          else if s[i] = 'x' then

          begin

           smsg[i] := 0;

           mask[i] := 1;

          end

          else if s[i] = 'X' then

          begin

           smsg[i] := 1;

           mask[i] := 1;

          end

          else

            b := false;

        if not b then

          writeln ('pattern format error');

      end;

    until b;

    c := #0;

    writeln ('m=inc n=dec <spc>=repeat <ret>=save message');

    repeat

      if c <> ' 'then

      begin

        encsmsg (smsg,msg,p);

        for i := 1 to bits do

          write (smsg[i]:1);

      end;

      for i := 1 to 3 do

      begin

        putmsg (msg,p);

        write ('T');

      end;

      c := readkeyrepeat;

      if c = 'm' then

      begin

        b := true;

        for i := 1 to bits do

          if b and (mask[i] = 1) then

          begin

            smsg[i] := 1-smsg[i];

            b := (smsg[i] = 0);

          end;

        writeln;

      end

      else if c = 'n' then

      begin

        b := true;

        for i := 1 to bits do

          if b and (mask[i] = 1) then

          begin

            smsg[i] := 1-smsg[i];

            b := (smsg[i] = 1);

          end;

        writeln;

      end;

    until c = #13;

    writeln;

    write ('function name (<ret> to cont/quit) ? ');

    readln (s);

    if s = '' then

    begin

      repeat

        repeat

          write ('c=continue q=quit ? ');

          readln (c);

        until (c = 'c') or (c = 'q');

        if c = 'e' then

        begin

          repeat

            write ('quit (y/n) ? ');

            readln (c);

          until (c = 'n') or (c = 'y');

          if c = 'y' then

            c := 'q';

        end;

      until (c = 'c') or (c = 'q');

    end

    else

    begin

      c := #0;

      for i := 1 to bits do

        write (f,smsg[i]:1);

      writeln (f,':',s);

      write ('saving ');

      for i := 1 to bits do

        write (smsg[i]:1);

      writeln (':',s);

      inc (cnt);

    end;

  until c = 'q';

  close (f);

  writeln (cnt,' keys saved');

end;





{ main }



begin

  readkeylast := #0;

  writeln ('SIRCS - Serial Infrared Remote Control System (Ver. 4)');

  writeln ('Heiko Purnhagen   27-nov-95, 30-jun-96, 19-aug-96, 08-sep-96');

  writeln ('e-mail: purnhage@tnt.uni-hannover.de');

  writeln ('WWW:    http://www.fet.uni-hannover.de/purnhage/');

  writeln;

  writeln ('Modified by sircs 30-may 98');

  writeln ('email: sircs@geocities.com');

  writeln ('WWW:    http://geocities.com/capecanaveral/launchpad/4652');

  writeln ('Now reads 12bit,15bit & 20bit');

  writeln;

  writeln ('usage: SIRCSALL');

  writeln ('   or: SIRCSALL [<com> <level> <filename.sny>]');

  writeln ('       <com> port: 1,2,3,4');

  writeln ('       output active <level>: 0=low 1=high 2,3=LED');

  writeln;

  if paramcount > 0 then

  begin

    if paramcount <> 3 then

    begin

      writeln ('parameter error');

      exit;

    end;

    val (paramstr(1),com,err);

    if (err <> 0) or (com < 1) or (com > 4) then

    begin

      writeln ('<com> parameter error');

      exit;

    end;

    invrx := 0;

    invtx := 2;

    b := initio(com);

    if not b then

    begin

      writeln ('com',com,' error');

      exit;

    end;

    restoreio;

    val (paramstr(2),invtx,err);

    if (err <> 0) or (invtx < 0) or (invtx > 3) then

    begin

      writeln ('<level> parameter error');

      exit;

    end;

    fns := paramstr(3);

    invtx := invtx xor 1;

    invrx := 0;

    rpt := 3;

  end

  else

  begin

    rpt := 0;

    repeat

      write ('com (1,2,3,4)? ');

      readln (com);

    until (com >= 1) and (com <= 4);

    invrx := 0;

    invtx := 2;

    b := initio(com);

    if not b then

    begin

      writeln ('com',com,' error');

      exit;

    end;

    restoreio;

    repeat

      write ('receiver input active level (0=low, 1=high) ? ');

      readln (invrx);

    until (invrx = 0) or (invrx = 1);

    invrx := 1-invrx;

    repeat

      write ('transmitter output active level (0=low, 1=high, 2,3=LED) ? ');

      readln (invtx);

    until (invtx >= 0) and (invtx <= 3);

    invtx := invtx xor 1;

    repeat

    write ('number of bits 12, 15 or 20 ? ');

    readln (bits);

    until (bits =12) or (bits=15) or (bits=20);

  end;

  initclk;

  tmg := clkmax;

  writeln ('system timing: ',tmg:8:6,' sec');

  if tmg > 0.000100 then

  begin

    writeln ('WARNING: unstable or slow system timing');

    writeln ('         -> SIRCS might not operate reliable!');

    writeln ('Hint: Don''t use SIRCS from a DOS-Window within MS-Windows.');

    writeln;

    write ('continue (y/n): ');

    readln (yn);

    if yn <> 'y' then

      exit;

  end;

  b := initio(com);

  if rpt > 0 then

    playsony(false,fns,rpt)

  else

    repeat

      writeln;

      writeln ('1=test receiver (textmode)');

      writeln ('2=test receiver (graphic)');

      writeln ('3=test timing and echo messages');

      writeln ('4=save basic mesages to file');

      writeln ('5=receive and echo sony message');

      writeln ('6=receive sony messages to file');

      writeln ('7=transmit sony messages from file (USE THIS!!!)');

      writeln ('8=generate and transmit sony messages');

      writeln ('9=transmit sony messages from file (verbose)');

      writeln ('0=quit');

      write ('? ');

      readln (c);

      case c of

        '1' : testtext;

        '2' : testgraph;

        '3' : testtime;

        '4' : timetofile;

        '5' : testsony;

        '6' : savesony;

        '7' : playsony(false,'',0);

        '8' : trysony;

        '9' : playsony(true,'',0);

      end;

    until c = '0';

  restoreio;

end.



