(*---------------------------------------------------------------------------
  :Program.     Spectroscope.mod
  :Contents.    Echtzeit Frequenzanalyse mit Parallelport-Samplern
  :Author.      Christian Stiens
  :Address.     Heustiege 2, W-4710 Lüdinghausen
  :Copyright.   Freeware, © 1992 by CS-soft, All Rights Reserved
  :Language.    Oberon-2
  :Translator.  Amiga Oberon V2.25d
  :History.     V1.0, 03-Mar-92
  :Imports.     AudioSupport (AMOK #58), Borders (AMOK #57), FFT
---------------------------------------------------------------------------*)

MODULE Spectroscope;

  IMPORT
    as : AudioSupport,
    b  : Borders,
    e  : Exec,
    es : ExecSupport,
         FFT,
    g  : Graphics,
    hw : Hardware,
    I  : Intuition,
    p  : Parallel,
    rq : Requests,
    sys: SYSTEM;

  CONST
    n = 64;           (* 64 Punkt FFT *)
    m = n DIV 2;      (* Anzahl Säulen *)
    d = 3;            (* Absinkrate der Anzeige *)
    x0 = 35;          (* Offset der Anzeige *)
 (* y0 = 30; *)
    w1 = 5;           (* Breite der Säulen *)
    w2 = 10;          (* Abstand der Säulen *)
    w  = w2*(m-1)+w1;

  TYPE
    PropGadget = STRUCT (gad : I.Gadget)
      info: I.PropInfo;
    END;

  VAR
    nw       : I.NewWindow;
    par      : STRUCT
                 port : e.MsgPortPtr;
                 io   : p.IOExtParPtr;
                 dev  : e.DevicePtr;
               END;
    win      : I.WindowPtr;
    scr      : I.ScreenPtr;
    mes      : I.IntuiMessage;
    chan     : SHORTINT;
    per      : INTEGER;
    gad      : I.Gadget;
    xgad     : I.Gadget;
    knob     : I.Image;
    level    : INTEGER;
    y0       : INTEGER;
    slider   : PropGadget;
    i,x      : INTEGER;
    rp       : g.RastPortPtr;
    hold,last: ARRAY m+1 OF INTEGER;
    xreal,
    ximag    : ARRAY n OF INTEGER;
    border3D : b.Border3D;
    version  : ARRAY 40 OF CHAR;
    sintab ["_sintab_1024x16"] : ARRAY 1024 OF INTEGER;

(*---------------------------------------------------------------------*)

  CONST
    freqWidth  = 304;
    freqHeight =  16;

  (* $DataChip+ *)

  TYPE IntArray304 = ARRAY 304 OF INTEGER;

  CONST freqData = IntArray304(
    (* [0] *)
    0C198U,0000CU,00000U,000F0U,00000U,003C0U,00000U,00700U,00000U,03F00U,
    00000U,0F000U,00007U,0E000U,0000FU,00000U,0003CU,00000U,0031EU,
    0D99BU,0E01CU,00000U,00198U,00000U,00660U,00000U,00F00U,00000U,03000U,
    00001U,08000U,00000U,06000U,00019U,08000U,00066U,00000U,00733U,
    0F1F8U,0C00CU,00000U,00030U,00000U,000C0U,00000U,01B00U,00000U,03E00U,
    00001U,0F000U,00000U,0C000U,0000FU,00000U,0003EU,00000U,00333U,
    0D99BU,0000CU,00000U,000C0U,00000U,00660U,00000U,01F80U,00000U,00300U,
    00001U,09800U,00001U,08000U,00019U,08000U,00006U,00000U,00333U,
    0CD9BU,0E01EU,00000U,001F8U,00000U,003C0U,00000U,00300U,00000U,03E00U,
    00000U,0F000U,00003U,00000U,0000FU,00000U,0003CU,00000U,0079EU,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,003FEU,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00300U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00600U,0D8F0U,03D98U,061E1U,0BC1FU,01860U,
    00000U,00000U,00000U,00000U,07C60U,00000U,00000U,03000U,00000U,
    00000U,00000U,00000U,00000U,007F8U,0E30CU,0C398U,06619U,0C661U,09860U,
    00000U,00000U,00000U,00000U,0C66EU,03C6EU,0371EU,03180U,00000U,
    00000U,00000U,00000U,00000U,00C01U,087F9U,08330U,0CFF3U,00CC0U,01980U,
    00000U,00000U,00000U,00000U,0C073U,00E73U,039BFU,03000U,00000U,
    00000U,00000U,00000U,00000U,00C01U,08601U,08731U,0CC03U,00CC3U,00D80U,
    00000U,00000U,00000U,00000U,0C663U,07663U,031B0U,03180U,00000U,
    00000U,00000U,00000U,00000U,01803U,003E0U,0F61DU,087C6U,0187CU,00E00U,
    00000U,00000U,00000U,00000U,07C63U,03E63U,0319EU,01800U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00600U,00000U,00000U,00C00U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00C00U,00000U,00000U,07000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U);

(*---------------------------------------------------------------------*)

  CONST
    levelWidth  = 37;
    levelHeight = 5;

  (* $DataChip+ *)

  TYPE IntArray15 = ARRAY 15 OF INTEGER;

  CONST levelData = IntArray15(
    (* [0] *)
    0C000U,00003U,00000U,
    0C1E3U,031E3U,01800U,
    0C3F3U,033F3U,00000U,
    0C301U,0E303U,01800U,
    0F9E0U,0C1E1U,08000U);

(*---------------------------------------------------------------------*)

  CONST
    dbWidth  = 18;
    dbHeight = 69;

  TYPE IntArray138 = ARRAY 1,138 OF INTEGER;

  (* $DataChip+ *)

  CONST dbData = IntArray138(
    (* [0] *)
    0006FU,00000U, 0036DU,08000U, 006EFU,08000U, 0066CU,0C000U, 003EFU,08000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00007U,08000U, 0000CU,0C000U,
    0000CU,0C000U, 0000CU,0C000U, 00007U,08000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00007U,08000U, 0000CU,00000U, 007CFU,08000U, 0000CU,0C000U, 00007U,08000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 00000U,00000U,
    00000U,00000U, 000C7U,08000U, 001CCU,0C000U, 0F8C1U,08000U, 000C6U,00000U,
    001EFU,0C000U, 00000U,00000U, 00000U,00000U, 00000U,00000U, 000C7U,08000U,
    001CCU,0C000U, 0F8C7U,08000U, 000CCU,0C000U, 001E7U,08000U);

(*---------------------------------------------------------------------*)

  TYPE IntArray12 = ARRAY 12 OF INTEGER;

  (* $DataChip+ *)

  CONST leftData  = IntArray12(03000U,07180U,03078U,0C3E0U,030FDU,0E180U,
                               030C0U,0C180U,03E78U,0C0C0U,00000U,00000U);

  CONST rightData = IntArray12(0F180U,06060U,0D81BU,06CF8U,0F1B7U,07660U,
                               0D9BBU,06660U,0CD87U,06630U,0001EU,00000U);

  left  = I.Image(4,2,29,6,1,sys.ADR(leftData) ,SHORTSET{0},SHORTSET{},NIL);
  right = I.Image(4,2,29,6,1,sys.ADR(rightData),SHORTSET{0},SHORTSET{},NIL);

(*---------------------------------------------------------------------*)

  (* $DataChip+ *)

  TYPE IntArray10 = ARRAY 10 OF INTEGER;

  CONST x1Data = IntArray10(
    00001U,08000U,03303U,08000U,00C01U,08000U,03301U,08000U,00003U,0C000U);

  CONST x10Data = IntArray10(
    0000CU,07800U,0331CU,0CC00U,00C0CU,0CC00U,0330CU,0CC00U,0001EU,07800U);

  x1Img  = I.Image(4,2,24,5,2,sys.ADR(x1Data),SHORTSET{0},SHORTSET{},NIL);
  x10Img = I.Image(4,2,24,5,2,sys.ADR(x10Data),SHORTSET{0},SHORTSET{},NIL);

(*---------------------------------------------------------------------*)

  TYPE IntArray30 = ARRAY 1,30 OF INTEGER;

  (* $DataChip+ *)

  CONST logoData = IntArray30(
    (* [0] *)
    00183U,00000U, 0060CU,00000U, 01C1CU,00000U, 0380FU,00000U, 07803U,0C000U,
    0FC01U,0F000U, 0FF9FU,0F000U, 0FF9FU,0F000U, 07F9FU,0C000U, 00000U,00000U,
    00006U,04000U, 01988U,0E000U, 0225CU,04000U, 01248U,04000U, 06188U,02000U);

  CONST
    logo = I.Image(0,0,20,15,1,sys.ADR(logoData),SHORTSET{0},SHORTSET{},NIL);

(*---------------------------------------------------------------------*)

  PROCEDURE Muls (i{0},j{1}: INTEGER): LONGINT; (* $EntryExitCode- *)
  BEGIN
    sys.INLINE(0C1C1H,04E75H);   (* MULS D1,D0 ; RTS *)
  END Muls;

(*---------------------------------------------------------------------*)

  PROCEDURE CloseParallel;
  BEGIN
    IF par.dev  # NIL THEN
      hw.ciab.ddra := hw.ciab.ddra - SHORTSET{1,2};
      e.CloseDevice(par.io);   par.dev  := NIL;
    END;
    IF par.io   # NIL THEN es.DeleteExtIO(par.io);  par.io   := NIL END;
    IF par.port # NIL THEN es.DeletePort(par.port); par.port := NIL END;
  END CloseParallel;

(*---------------------------------------------------------------------*)

  PROCEDURE OpenParallel(): BOOLEAN;
  BEGIN
    LOOP
      par.port := es.CreatePort("",0);
      IF par.port = NIL THEN EXIT END;
      par.io := es.CreateExtIO(par.port,SIZE(par.io^));
      IF par.io = NIL THEN EXIT END;
      IF e.OpenDevice("parallel.device",0,par.io,LONGSET{}) # 0 THEN EXIT END;
      par.dev := par.io.ioPar.device;
      RETURN TRUE;
    END;
    CloseParallel;
    RETURN FALSE
  END OpenParallel;

(*---------------------------------------------------------------------*)

  PROCEDURE Plot;
    VAR i,j,k: INTEGER;
  BEGIN
    k := x0;
    FOR i := 1 TO m DO
      j := SHORT(Muls(xreal[i],level) DIV 512);
      IF j > 65 THEN j := 65 END;
      IF j > hold[i] THEN hold[i] := j ELSE j := hold[i] END;
      IF    j > last[i] THEN g.SetAPen(rp,2);
                             g.RectFill(rp,k,(y0+65)-j,k+w1,(y0+64)-last[i])
      ELSIF j < last[i] THEN g.SetAPen(rp,1);
                             g.RectFill(rp,k,(y0+65)-last[i],k+w1,(y0+64)-j)
      END;
      last[i] := j;
      DEC(hold[i],d);
      INC(k,w2);
    END;
  END Plot;

(*---------------------------------------------------------------------*)

  PROCEDURE Record;
    VAR i: INTEGER;
        prb: SHORTINT;
        audci: SHORTINT;
  BEGIN
    (* $RangeChk- $OvflChk- $NilChk- *)

    audci := hw.aud0i + chan;

    (* Audio-Kanal für's Timing benutzen: *)

    hw.custom.intena := {audci};    (* Audio-Interrupt sperren *)

    hw.custom.aud[chan].ptr := NIL;
    hw.custom.aud[chan].len := 1;   (* 1 Wort *)
    hw.custom.aud[chan].per := per;
    hw.custom.aud[chan].vol := 0;

    hw.custom.dmacon := {hw.aud0+chan}; (* DMA aus *)

    hw.custom.intreq := {audci};
    hw.custom.aud[chan].dat := 1;

    e.Disable;

    (* Ersten Wert ignorieren: *)

    prb := sys.VAL(SHORTINT,hw.ciaa.prb) + sys.VAL(SHORTINT,-128);

    FOR i := 0 TO n-1 DO
      REPEAT UNTIL audci IN hw.custom.intreqr; (* Auf Audio-Interrupt warten *)
      hw.custom.intreq := {audci};             (* Interrupt-Bit zurücksetzen *)
      hw.custom.aud[chan].dat := 1;            (* Datenregister beschreiben *)

      (* Parallel-Port lesen: *)

      prb := sys.VAL(SHORTINT,hw.ciaa.prb) + sys.VAL(SHORTINT,-128);

      xreal[i] := LONG(prb);
    END;

    e.Enable;

    (* Mit Hammingfunktion gewichten: *)

    FOR i := 0 TO n-1 DO
      x := (i * (1024 DIV n) + 768) MOD 1024;
      xreal[i] := xreal[i] * (sintab[x] DIV 512 + 64);
      ximag[i] := 0;
    END;

    (* $RangeChk= $OvflChk= $NilChk= *)

  END Record;

(*---------------------------------------------------------------------*)

  PROCEDURE Analyse;
  BEGIN
    FFT.FFT(xreal,ximag,n);   (* Fast-Fourier-Transform aufrufen *)
    FFT.Abs(xreal,ximag,m+1); (* Absolutwerte der komplexen Zahlen berechen *)
  END Analyse;

(*---------------------------------------------------------------------*)

  PROCEDURE GetIMsg(win: I.WindowPtr; VAR mes: I.IntuiMessage);
    VAR msg: I.IntuiMessagePtr;
  BEGIN
    msg := e.GetMsg(win.userPort);
    IF msg # NIL THEN
      mes := msg^;
      e.ReplyMsg(msg)
    ELSE
      mes.class := LONGSET{}
    END
  END GetIMsg;

(*---------------------------------------------------------------------*)

  PROCEDURE SetLevel;
  BEGIN
    level := SHORT(I.UIntToLong(slider.info.horizPot) DIV 1024);
  END SetLevel;

(*---------------------------------------------------------------------*)

  PROCEDURE HandleMessage(VAR mes: I.IntuiMessage);
  BEGIN
    IF I.selected IN slider.gad.flags THEN SetLevel END;
    IF mes.class = LONGSET{} THEN RETURN END;
    IF mes.class = LONGSET{I.closeWindow} THEN HALT(0) END;
    IF mes.class = LONGSET{I.gadgetDown} THEN
      IF mes.iAddress = sys.ADR(gad) THEN
        IF I.selected IN gad.flags THEN
          EXCL(hw.ciab.pra,1);                     (* Rechten Kanal *)
          INCL(hw.ciab.pra,2);                     (* selektieren   *)
        ELSE
         INCL(hw.ciab.pra,1);                      (* Linken Kanal *)
         EXCL(hw.ciab.pra,2);                      (* selektieren  *)
        END;
      ELSIF mes.iAddress = sys.ADR(xgad) THEN
        IF I.selected IN xgad.flags THEN per := 831
                                    ELSE per := 83 END;
      END;
    END;
    IF (mes.class=LONGSET{I.gadgetUp}) & (mes.iAddress=sys.ADR(slider)) THEN
      SetLevel
    END;
  END HandleMessage;

(*---------------------------------------------------------------------*)

BEGIN
  version := "$VER: spectroscope 1.0 (3.3.92)\n\r";
  win := NIL;
  par.port := NIL;
  par.io := NIL;
  par.dev := NIL;
  scr := NIL;
  per := 83;

  rq.Assert(OpenParallel(),"Can't open parallel.device");

  IF I.int.libNode.version >= 36 THEN scr := I.LockPubScreen(NIL)
                                 ELSE scr := I.OpenWorkBench() END;
  IF scr=NIL THEN HALT(0) END;

  y0 := (scr.wBorTop + scr.font.ySize + 1) + 17;

  gad := I.Gadget(NIL, x0+280,0, 37,10,
                  {I.gadgImage,I.gadgHImage},
                  {I.toggleSelect,I.gadgImmediate},
                  I.boolGadget,
                  NIL, NIL, NIL, LONGSET{}, NIL, 0, NIL);
  gad.topEdge := 75+y0;
  gad.gadgetRender := sys.ADR(left);
  gad.selectRender := sys.ADR(right);

  xgad := I.Gadget(NIL, x0+156,0, 32,9,
                  {I.gadgImage,I.gadgHImage},
                  {I.toggleSelect,I.gadgImmediate},
                  I.boolGadget,
                  NIL, NIL, NIL, LONGSET{}, NIL, 0, NIL);
  xgad.topEdge := 75+y0;
  xgad.gadgetRender := sys.ADR(x1Img);
  xgad.selectRender := sys.ADR(x10Img);

  slider := PropGadget(NIL, x0+145,0, 64,4,
                       {I.gadgImage},
                       {I.relVerify,I.gadgImmediate},
                       I.propGadget,
                       NIL, NIL, NIL, LONGSET{}, NIL, 0, NIL,
                       {I.freeHoriz,I.autoKnob,I.propBorderless},
                       32767,0, 1024,0, 0,0, 0,0, 0,0);
  slider.gad.topEdge := y0-10;
  slider.gad.gadgetRender := sys.ADR(knob);
  slider.gad.specialInfo := sys.ADR(slider.info);

  nw := I.NewWindow(100, 50,
                    w+60, 0,
                    -1,-1,
                    LONGSET{I.closeWindow,I.gadgetDown,I.gadgetUp},
                    LONGSET{I.windowDrag,I.windowDepth,I.windowClose,I.activate},
                    NIL,NIL,
                    sys.ADR("Spectroscope V1.0"),
                    NIL,NIL, 0,0,0,0,
                    I.customScreen);

  nw.screen := scr;
  nw.height := (scr.wBorTop+scr.font.ySize+1) + 109;

  win := I.OpenWindow(nw);
  rq.Assert(win # NIL,"Can't open window");
  rp := win.rPort;

  I.DrawBorder(rp,b.InitBorder(border3D,2,1,0,w2*m+8,64+5),x0-6,y0-2);
  I.DrawImage(rp,I.Image(0,0,freqWidth,freqHeight,1,sys.ADR(freqData),SHORTSET{0},SHORTSET{},NIL),x0-5,y0+68);
  I.DrawImage(rp,I.Image(0,0,dbWidth,dbHeight,1,sys.ADR(dbData),SHORTSET{0},SHORTSET{},NIL),x0-28,y0-10);
  I.DrawImage(rp,I.Image(0,0,levelWidth,levelHeight,1,sys.ADR(levelData),SHORTSET{0},SHORTSET{},NIL),x0+100,y0-11);
  I.DrawBorder(rp,b.InitBorder(border3D,2,1,0,gad.width,gad.height),gad.leftEdge,gad.topEdge);
  I.DrawBorder(rp,b.InitBorder(border3D,2,1,0,xgad.width,xgad.height),xgad.leftEdge,xgad.topEdge);
  I.DrawBorder(rp,b.InitBorder(border3D,2,1,0,slider.gad.width+8,slider.gad.height+4),slider.gad.leftEdge-4,slider.gad.topEdge-2);
  I.DrawImage(rp,logo,10,y0+74);

  sys.SETREG(0,I.AddGadget(win,gad,-1));
  sys.SETREG(0,I.AddGadget(win,xgad,-1));
  sys.SETREG(0,I.AddGadget(win,slider,-1));

  I.RefreshGadgets(sys.ADR(gad),win,NIL);

  g.SetAPen(rp,3);
  g.Move(rp,x0-4,y0+32); g.Draw(rp,x0+4+w,y0+32);
  g.Move(rp,x0-4,y0+48); g.Draw(rp,x0+4+w,y0+48);
  g.Move(rp,x0-4,y0+56); g.Draw(rp,x0+4+w,y0+56);

  level := 0;

  FOR i := 0 TO m DO last[i] := 65 END;
  Plot;

  SetLevel;

  as.SetPriority(127);        (* Kanal darf nicht gestohlen werden *)
  chan := as.OpenChannel({}); (* Irgend einen Audiokanal öffnen *)

  hw.ciaa.ddrb := SHORTSET{};                   (* Alle Bits sind Eingang *)
  hw.ciab.ddra := hw.ciab.ddra + SHORTSET{1,2}; (* Bit 1 & 2 Ausgang *)
  INCL(hw.ciab.pra,1);                          (* Linken Kanal *)
  EXCL(hw.ciab.pra,2);                          (* selektieren  *)

  LOOP
    GetIMsg(win,mes);
    HandleMessage(mes);
    Record;
    Analyse;
    Plot;
    g.WaitTOF;
  END;

CLOSE

  as.CloseChannel(chan);
  IF win # NIL THEN I.CloseWindow(win) END;
  IF I.int.libNode.version >= 36 THEN
    IF scr#NIL THEN I.UnlockPubScreen(NIL,scr) END
  END;
  CloseParallel;

END Spectroscope.