(*---------------------------------------------------------------------------
  :Program.     Spectrum.mod
  :Contents.    Spektralanalyse von 8-Bit Samples
  :Author.      Christian Stiens
  :Address.     Heustiege 2, W-4710 Lüdinghausen
  :Copyright.   PD
  :Language.    Oberon
  :Translator.  Amiga Oberon V2.12e [fbs]
  :History.     V1.0, 01-Nov-91
  :Imports.     FFT, AudioSupport (AMOK#58)
---------------------------------------------------------------------------*)

MODULE Spectrum;

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

  IMPORT
    as : AudioSupport,
    fs : FileSystem,
    arg: Arguments,
    I  : Intuition,
    g  : Graphics,
    e  : Exec,
    ol : OberonLib,
    rq : Requests,
    str: Strings,
    sys: SYSTEM,
    Dos,FFT;

  VAR
    nw        : I.NewWindow;
    file      : fs.File;
    win       : I.WindowPtr;
    name      : e.STRING;
    title     : e.STRING;
    size      : LONGINT;
    bufsize   : LONGINT;
    num       : INTEGER;
    sound     : e.ADDRESS;
    mes       : I.IntuiMessage;
    gad       : I.Gadget;
    chan      : SHORTINT;
    rp        : g.RastPortPtr;
    buf       : POINTER TO SHORTINT;
    horizon   : ARRAY 640 OF INTEGER;
    xreal,
    ximag     : ARRAY 256 OF INTEGER;
    i,j,x,y,
    xold,yold : INTEGER;
    img       : I.Image;
    sintab ["_sintab_1024x16"] : ARRAY 1024 OF INTEGER;

  CONST
    per = 400;    (* Period-Wert für Tonausgabe *)

  CONST
    TimeWidth  = 37;
    TimeHeight = 17;
    FreqWidth  = 396;
    FreqHeight = 16;
    SpeakerWidth  = 34;
    SpeakerHeight = 12;

  (* $DataChip+ *)

  TYPE IntArray51 = ARRAY 51 OF INTEGER;

  CONST TimeData = IntArray51(
    (* [0] *)
    00000U,00000U,0C000U, 00000U,0001FU,0C000U, 00000U,001F7U,0C000U,
    00000U,00006U,0C000U, 00000U,0000CU,0E000U, 00000U,00018U,06000U,
    00000U,00030U,00000U, 00000U,00060U,00000U, 00000U,000C0U,00000U,
    00000U,00000U,00000U, 0FFCCU,00000U,00000U, 00C00U,00000U,00000U,
    01819U,0B9C1U,0E000U, 01819U,0CE66U,01800U, 03033U,018CFU,0F000U,
    03033U,018CCU,00000U, 06066U,03187U,0C000U);

  TYPE IntArray400 = ARRAY 400 OF INTEGER;

  CONST FreqData = IntArray400(
    (* [0] *)
    00180U,00000U,00000U,03000U,00000U,00006U,00000U,00000U,000C0U,00000U,00000U,01800U,00000U,00003U,00000U,00000U,00060U,00000U,00000U,00C00U,00000U,00001U,08000U,00000U,00000U,
    00180U,00000U,00000U,03000U,00000U,00006U,00000U,00000U,000C0U,00000U,00000U,01800U,00000U,00003U,00000U,00000U,00060U,00000U,00000U,00C00U,00000U,00001U,08000U,00000U,00000U,
    00180U,00000U,00000U,00000U,00000U,00006U,00000U,00000U,00000U,00000U,00000U,01800U,00000U,00000U,00000U,00000U,00060U,00000U,00000U,00000U,00000U,00001U,08000U,00000U,00000U,
    0781EU,00000U,00000U,00000U,00000U,000C0U,07800U,00000U,00000U,00000U,00007U,081E0U,00000U,00000U,00000U,00000U,01E07U,08000U,00000U,00000U,00000U,00038U,01E00U,00060U,0CC00U,
    0CC33U,00000U,00000U,00000U,00000U,001C0U,0CC00U,00000U,00000U,00000U,0000CU,0C330U,00000U,00000U,00000U,00000U,0330CU,0C000U,00000U,00000U,00000U,00078U,03300U,0006CU,0CDF0U,
    0CC33U,00000U,00000U,00000U,00000U,000C0U,0CC00U,00000U,00000U,00000U,00001U,08330U,00000U,00000U,00000U,00000U,0060CU,0C000U,00000U,00000U,00000U,000D8U,03300U,00078U,0FC60U,
    0CC33U,00000U,00000U,00000U,00000U,000C0U,0CC00U,00000U,00000U,00000U,00006U,00330U,00000U,00000U,00000U,00000U,0330CU,0C000U,00000U,00000U,00000U,000FCU,03300U,0006CU,0CD80U,
    0799EU,00000U,00000U,00000U,00000U,001E6U,07800U,00000U,00000U,0007FU,0C00FU,0D9E0U,00000U,00000U,00000U,00000U,01E67U,08000U,00000U,00000U,00000U,00019U,09E00U,00066U,0CDF0U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00060U,00000U,00000U,00000U,00000U,00000U,00018U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,000C0U,01B1EU,007B3U,00C3CU,03783U,0E30CU,0000EU,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,000FFU,01C61U,09873U,00CC3U,038CCU,0330CU,00003U,08000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00180U,030FFU,03066U,019FEU,06198U,00330U,01FFFU,0E000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00180U,030C0U,030E6U,03980U,06198U,061B0U,00003U,08000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00300U,0607CU,01EC3U,0B0F8U,0C30FU,081C0U,0000EU,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,000C0U,00000U,00000U,00180U,00018U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,
    00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00180U,00000U,00000U,00E00U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U,00000U);

  TYPE IntArray72 = ARRAY 2,36 OF INTEGER;

  CONST SpeakerData * = IntArray72(
    (* [0] *)
    00000U,00000U,04000U, 00000U,00000U,0C000U, 00000U,0C020U,0C000U,
    003F3U,08120U,0C000U, 0033CU,08890U,0C000U, 00330U,08490U,0C000U,
    00330U,08490U,0C000U, 0033CU,08890U,0C000U, 003F3U,08120U,0C000U,
    00000U,0C020U,0C000U, 00000U,00000U,0C000U, 07FFFU,0FFFFU,0C000U,
    (* [1] *)
    0FFFFU,0FFFFU,08000U, 0C000U,00000U,00000U, 0C000U,00000U,00000U,
    0C000U,00000U,00000U, 0C000U,00000U,00000U, 0C000U,00000U,00000U,
    0C000U,00000U,00000U, 0C000U,00000U,00000U, 0C000U,00000U,00000U,
    0C000U,00000U,00000U, 0C000U,00000U,00000U, 08000U,00000U,00000U);


  PROCEDURE Error (txt: ARRAY OF CHAR); (* $CopyArrays- *)
  BEGIN
    IF ol.wbStarted THEN
      rq.Assert(FALSE,txt);
    END;
    sys.SETREG(0,Dos.Write(Dos.Output(),txt,LEN(txt)-1));
    sys.SETREG(0,Dos.Write(Dos.Output(),"\n",1));
    HALT(20);
  END Error;


  PROCEDURE SGN (i: INTEGER): INTEGER;
  BEGIN
    IF    i > 0 THEN RETURN +1
    ELSIF i < 0 THEN RETURN -1
    ELSE             RETURN  0
    END;
  END SGN;


  (* Linie von (x0,y0) nach (x1,y1) unter Beachtung des 'floating horizon'
     malen *)

  PROCEDURE Line(rp: g.RastPortPtr; x0,y0,x1,y1: INTEGER; clear: BOOLEAN);
    VAR dx,dy,gx,gy,lx,ly,m,n,i,d: INTEGER;
  BEGIN
    dx := SGN(x1-x0); gx := dx;
    dy := SGN(y1-y0); gy := dy;
    lx := ABS(x1-x0); ly := ABS(y1-y0);
    IF lx > ly THEN gy:=0; n:=lx; d:=ly
               ELSE gx:=0; n:=ly; d:=lx END;
    m := n DIV 2;
    i := 0; WHILE i <= n DO
      IF clear THEN
        IF (y0 > horizon[x0]) & (g.ReadPixel(rp,x0,y0) = 1) THEN
          sys.SETREG(0,g.WritePixel(rp,x0,y0));
        END;
      ELSE
        IF y0 < horizon[x0] THEN
          sys.SETREG(0,g.WritePixel(rp,x0,y0));
          horizon[x0] := y0
        END;
      END;
      INC(m,d);
      IF m >= n THEN INC(x0,dx); INC(y0,dy); DEC(m,n)
                ELSE INC(x0,gx); INC(y0,gy) END;
    INC(i) END;
  END Line;


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


BEGIN

  win := NIL;

  arg.GetArg(1,name);

  IF (name[0] = "?") OR (name[0] = 0X) THEN
    Error("Usage: Spectrum <file>");
  END;

  IF NOT fs.Open(file,name,FALSE) THEN Error("Can't open file") END;
  size := fs.Size(file);
  IF size = 0 THEN Error("File empty") END;
  num := SHORT((size + 255) DIV 256);
  IF num < 10 THEN num := 10 END;
  IF num > 73 THEN num := 73 END;  (* Damit win.height <= 200 *)
  bufsize := LONG(num) * 256;
  INCL(ol.MemReqs,e.chip); ol.New(buf,bufsize); EXCL(ol.MemReqs,e.chip);
  IF buf = NIL THEN Error("Out of memory") END;
  sound := buf;
  IF size > bufsize THEN size := bufsize END;
  IF NOT fs.ReadBlock(file,buf,size) THEN Error("Read error") END;

  nw := I.NewWindow(20,0,400,100,-1,-1,LONGSET{I.closeWindow,I.gadgetUp},
                 LONGSET{I.windowDrag,I.windowDepth,I.windowClose,I.activate},
                 NIL,NIL,NIL,NIL,NIL,0,0,0,0,{I.wbenchScreen});

  nw.height := 54 + num * 2;
  nw.width := 440 + num * 2;

  gad := I.Gadget(NIL,20,18,SpeakerWidth,SpeakerHeight,{},{I.relVerify},
                  I.boolGadget,NIL,NIL,NIL,LONGSET{},NIL,0,NIL);

  nw.firstGadget := sys.ADR(gad);

  title := "Spectrum of "; str.Append(title,name);
  nw.title := sys.ADR(title);

  win := I.OpenWindow(nw);
  IF win = NIL THEN Error("Can't open window") END;
  rp := win.rPort; g.SetAPen(rp,1);

  img := I.Image(0,0,SpeakerWidth,SpeakerHeight,2,sys.ADR(SpeakerData),SHORTSET{0,1},SHORTSET{},NIL);
  I.DrawImage(rp,img,gad.leftEdge,gad.topEdge);

  img := I.Image(0,0,FreqWidth,FreqHeight,1,sys.ADR(FreqData),SHORTSET{0},SHORTSET{},NIL);
  I.DrawImage(rp,img,33,nw.height-18);

  img := I.Image(0,0,TimeWidth,TimeHeight,1,sys.ADR(TimeData),SHORTSET{0},SHORTSET{},NIL);
  I.DrawImage(rp,img,num-5,nw.height-32-num);

  g.Move(rp,40,nw.height-19);                 (* Rand malen *)
  g.Draw(rp,424,nw.height-19);
  g.Draw(rp,424+num*2,nw.height-19-num*2);
  g.Draw(rp,40+num*2,nw.height-19-num*2);
  g.Draw(rp,40,nw.height-19);

  i := 0; WHILE i < (SIZE(horizon) DIV SIZE(INTEGER)) DO
    horizon[i] := MAX(INTEGER);
  INC(i) END;

  g.SetAPen(rp,2);

  as.SetPriority(-50);
  as.DontAbort;
  chan := as.OpenChannel({});
  IF chan = -1 THEN I.OffGadget(gad,win,NIL) END;

  i := 0; WHILE i < num DO

    GetIMsg(win,mes,FALSE);

    IF I.closeWindow IN mes.class THEN
      HALT(0)
    ELSIF I.gadgetUp IN mes.class THEN
      as.PlaySound(chan,sound,bufsize,per,64,1);
    END;

    j := 0; WHILE j < 256 DO
      x := (j * 4 + 768) MOD 1024;
      xreal[j] := LONG(buf^) * (sintab[x] DIV 256 + 128);
      ximag[j] := 0;
      buf := sys.VAL(sys.ADDRESS,sys.VAL(LONGINT,buf) + 1);
    INC(j) END;

    FFT.FFT(xreal,ximag,256);
    FFT.Abs(xreal,ximag,256);

    xreal[0] := 0;
    xreal[127] := 0;

    j := 0;
    x := j*3+42+i*2; y := nw.height-20-i*2-(xreal[j] DIV 256);
    j := 1; WHILE j < 128 DO
      xold := x; yold := y;
      x := j*3+42+i*2; y := nw.height-20-i*2-(xreal[j] DIV 256);
      Line(rp,xold,yold,x,y,FALSE);
    INC(j) END;
  INC(i) END;

  g.SetAPen(rp,0);
                     (* Verdeckten Rand löschen *)

  Line(rp,424+num*2,nw.height-19-num*2,40+num*2,nw.height-19-num*2,TRUE);
  Line(rp,40+num*2,nw.height-19-num*2,40,nw.height-19,TRUE);

  REPEAT
    GetIMsg(win,mes,TRUE);
    IF I.gadgetUp IN mes.class THEN
      as.PlaySound(chan,sound,bufsize,per,64,1);
    END;
  UNTIL I.closeWindow IN mes.class;

CLOSE

  IF win # NIL THEN I.CloseWindow(win) END;

END Spectrum.