(*---------------------------------------------------------------------------
  :Program.     Spectroscope.mod
  :Contents.    Realtime frequency analysis with sound samplers
  :Author.      Christian Stiens
  :Address.     Heustiege 2, W-4710 Lüdinghausen, GERMANY
  :Copyright.   Freeware, © 1992 by CS-soft, All Rights Reserved
  :Language.    Oberon
  :Translator.  Amiga Oberon V2.25 (inofficial beta version)
  :History.     V1.0, 03-Mar-92, first release
  :History.     V1.1, 08-May-92, code cosmetics
  :Imports.     DeviceSupport, FFT
  :Remark.      Compile:  Oberon -md DeviceSupport FFT Spectroscope
  :Remark.      Link:     OLink Spectroscope -md OBJ sintab_1024x16.o
---------------------------------------------------------------------------*)

MODULE Spectroscope;

  (* $RangeChk- $OvflChk- $NilChk- *)

  IMPORT
    au : Audio,
    ds : DeviceSupport,
    e  : Exec,
    es : ExecSupport,
         FFT,
    g  : Graphics,
    hw : Hardware,
    I  : Intuition,
         Misc,
    rq : Requests,
    sys: SYSTEM;

  CONST
    n = 64;           (* 64 Point FFT *)
    m = n DIV 2;      (* Number levelmeters *)
    d = 3;            (* sinking rate *)
    x0 = 35;          (* Offset of display *)
    w1 = 5;           (* width of levelmeters *)
    w2 = 10;          (* distance between levelmeters *)
    w  = w2*(m-1)+w1;

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

  VAR
    nw       : I.NewWindow;
    win      : I.WindowPtr;
    scr      : I.ScreenPtr;
    ioa      : au.IOAudioPtr;
    mes      : I.IntuiMessage;
    chan     : SHORTINT;
    per      : INTEGER;
    gad      : I.Gadget;
    xgad     : I.Gadget;
    knob     : I.Image;
    pp,pb    : e.APTR;
    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;
    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 DrawBorder (rp: g.RastPortPtr; x,y,w,h: INTEGER);
  BEGIN
    g.SetAPen(rp,2);
    g.Move(rp,x+1,y+h-2); g.Draw(rp,x+1,y); g.Draw(rp,x+w-2,y);
    g.Move(rp,x,y); g.Draw(rp,x,y+h-1);
    g.SetAPen(rp,1);
    g.Move(rp,x+1,y+h-1); g.Draw(rp,x+w-2,y+h-1); g.Draw(rp,x+w-2,y+1);
    g.Move(rp,x+w-1,y); g.Draw(rp,x+w-1,y+h-1);
  END DrawBorder;

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

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

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

  (* $StackChk- *)

  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;

    (* use audio channel for timing: *)

    hw.custom.intena := {audci};    (* disable audio interrupt *)

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

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

    hw.custom.intreq := {audci};

    e.Disable;

    hw.custom.aud[chan].dat := 0;

    (* ignore first value: *)

    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; (* Wait on audio interrupt *)
      hw.custom.intreq := {audci};             (* reset interrupt bit *)
      hw.custom.aud[chan].dat := 0;            (* write data register *)

      (* read the parallel port: *)

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

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

    e.Enable;

    (* Multiply with hamming function: *)

    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 Analysis;
  BEGIN
    FFT.FFT(xreal,ximag,n);   (* Call FFT *)
    FFT.Abs(xreal,ximag,m+1); (* Calc absolute values of the complex numbers*)
  END Analysis;

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

  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); INCL(hw.ciab.pra,2); (* right channel *)
        ELSE
         INCL(hw.ciab.pra,1); EXCL(hw.ciab.pra,2);  (* left channel *)
        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;

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

  PROCEDURE IoInit (ioa: e.MessagePtr);
    CONST allocMap = "\x01\x02\x04\x08";
  BEGIN
    WITH ioa: au.IOAudioPtr DO
      ioa.data := sys.ADR(allocMap);
      ioa.length := 4;
      ioa.request.message.node.pri := 127;
    END;
  END IoInit;

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


BEGIN
  version := "$VER: spectroscope 1.1 (8.5.92)\n\r";
  win := NIL;
  scr := NIL;
  ioa := NIL;
  per := 83;
  pp := -1;
  pb := -1;

  Misc.base := e.OpenResource(Misc.miscName);
  IF Misc.base=NIL THEN HALT(0) END;

  pp := Misc.AllocMiscResource(Misc.parallelPort,"Spectroscope");
  pb := Misc.AllocMiscResource(Misc.parallelBits,"Spectroscope");

  rq.Assert((pp=NIL) & (pb=NIL),"Can't alloc parallel port");

  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.1"),
                    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;

  DrawBorder(rp,x0-6,y0-2,w2*m+8,64+5);
  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);
  DrawBorder(rp,gad.leftEdge,gad.topEdge,gad.width,gad.height);
  DrawBorder(rp,xgad.leftEdge,xgad.topEdge,xgad.width,xgad.height);
  DrawBorder(rp,slider.gad.leftEdge-4,slider.gad.topEdge-2,slider.gad.width+8,slider.gad.height+4);
  I.DrawImage(rp,logo,10,y0+74);

  IF (I.AddGadget(win,gad,-1) +
      I.AddGadget(win,xgad,-1) +
      I.AddGadget(win,slider,-1)) = 0 THEN END;

  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;

  ioa := ds.OpenDev(au.audioName,0,LONGSET{},SIZE(au.IOAudio),IoInit);
  rq.Assert(ioa # NIL,"Can't open audio.device");

  CASE sys.VAL(LONGINT,ioa.request.unit) OF
    1: chan := 0 |
    2: chan := 1 |
    4: chan := 2 |
    8: chan := 3     ELSE HALT(0)
  END;

  hw.ciaa.ddrb := SHORTSET{};                   (* All Bits are input *)
  hw.ciab.ddra := hw.ciab.ddra + SHORTSET{1,2}; (* Bit 1 & 2 are output *)
  INCL(hw.ciab.pra,1); EXCL(hw.ciab.pra,2);     (* choose left channel *)

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

CLOSE

  IF (pp=NIL)&(pb=NIL) THEN hw.ciab.ddra := hw.ciab.ddra-SHORTSET{1,2} END;
  IF ioa # NIL THEN ds.CloseDev(ioa) END;
  IF win # NIL THEN I.CloseWindow(win) END;
  IF (I.int.libNode.version>=36)&(scr#NIL) THEN I.UnlockPubScreen(NIL,scr)END;
  IF pp=NIL THEN Misc.FreeMiscResource(Misc.parallelPort) END;
  IF pb=NIL THEN Misc.FreeMiscResource(Misc.parallelBits) END;

END Spectroscope.