home *** CD-ROM | disk | FTP | other *** search
/ Da Capo / da_capo_vol1.bin / programs / amiga / misc / lichtorgel / lichtorgel.mod < prev    next >
Text File  |  1980-01-11  |  12KB  |  452 lines
  1. (*---------------------------------------------------------------------------
  2.   :Program.     Lichtorgel.mod
  3.   :Contents.    Simulation einer 8-Kanal Lichtorgel
  4.   :Author.      Christian Stiens
  5.   :Address.     Heustiege 2, W-4710 Lüdinghausen
  6.   :Copyright.   Freeware, All Rights Reserved, © 1992 by cs-soft
  7.   :Language.    Oberon-2
  8.   :Translator.  Amiga Oberon V2.42d (inofficial ß-version)
  9.   :History.     V1.0, 07-Sep-92
  10.   :Imports.     Menu (AMOK #59), FFT (AMOK #68)
  11. ---------------------------------------------------------------------------*)
  12.  
  13. (* $StackChk-  weil wenig lokale Variablen und keine Rekursion *)
  14.  
  15. MODULE Lichtorgel;
  16.  
  17.   IMPORT
  18.     au := Audio,
  19.     e  := Exec,
  20.     es := ExecSupport,
  21.           FFT,
  22.     g  := Graphics,
  23.     hw := Hardware,
  24.     I  := Intuition,
  25.           Misc,
  26.     m  := Menu,
  27.     rq := Requests,
  28.     ol := OberonLib,
  29.     sys:= SYSTEM;
  30.  
  31.   CONST
  32.     ver = "\o$VER: lichtorgel 1.0 (7.9.92)\n\r";
  33.     oom = "Speichermangel";
  34.  
  35.   CONST
  36.     n = 16;           (* 16 Punkt FFT *)
  37.  
  38.   VAR
  39.     nw       : I.NewWindow;
  40.     win      : I.WindowPtr;
  41.     scr      : I.ScreenPtr;
  42.     menu     : I.MenuPtr;
  43.     ioa      : au.IOAudioPtr;
  44.     mes      : I.IntuiMessage;
  45.     pp,pb    : e.APTR;
  46.     chan     : SHORTINT;
  47.     col      : ARRAY 16 OF INTEGER;
  48.     i,w,x,y  : INTEGER;
  49.     shift    : INTEGER;
  50.     rp       : g.RastPortPtr;
  51.     vp       : g.ViewPortPtr;
  52.     hold     : ARRAY 8 OF INTEGER;
  53.     xreal,
  54.     ximag    : ARRAY n OF INTEGER;
  55.     sintab ["_sintab_1024x16"] : ARRAY 1024 OF INTEGER;
  56.  
  57. (*---------------------------------------------------------------------*)
  58.  
  59.   TYPE InitProc = PROCEDURE(ioReq: e.MessagePtr);
  60.  
  61.   PROCEDURE OpenDev (name   : ARRAY OF CHAR;
  62.                      unit   : LONGINT;
  63.                      flags  : LONGSET;
  64.                      ioSize : INTEGER;
  65.                      ioInit : InitProc): e.MessagePtr; (* $CopyArrays- *)
  66.     VAR
  67.       port: e.MsgPortPtr;
  68.       ioReq: e.IORequestPtr;
  69.  
  70.   BEGIN
  71.     port := es.CreatePort("",0);
  72.     IF port = NIL THEN RETURN NIL END;
  73.     IF ioSize = 0 THEN ioSize := SIZE(e.IOStdReq) END;
  74.     ioReq := es.CreateExtIO(port,ioSize);
  75.     IF ioReq = NIL THEN es.DeletePort(port); RETURN NIL END;
  76.     IF ioInit # NIL THEN ioInit(ioReq) END;
  77.     IF e.OpenDevice(name,unit,ioReq,flags) # 0 THEN
  78.       es.DeleteExtIO(ioReq);
  79.       es.DeletePort(port);
  80.       RETURN NIL
  81.     END;
  82.     RETURN ioReq;
  83.   END OpenDev;
  84.  
  85.   PROCEDURE CloseDev (ioReq: e.MessagePtr);
  86.     VAR port: e.MsgPortPtr;
  87.   BEGIN
  88.     port := ioReq.replyPort;
  89.     e.CloseDevice(ioReq);
  90.     es.DeleteExtIO(ioReq);
  91.     es.DeletePort(port);
  92.   END CloseDev;
  93.  
  94. (*---------------------------------------------------------------------*)
  95.  
  96.   PROCEDURE MakeTmpRas (rp: g.RastPortPtr);
  97.     VAR tmpRas : g.TmpRasPtr;
  98.         buffer : e.ADDRESS;
  99.         size   : LONGINT;
  100.   BEGIN
  101.     size := LONG(rp.bitMap.bytesPerRow) * LONG(rp.bitMap.rows);
  102.     INCL(ol.MemReqs,e.chip);
  103.     ol.New(buffer,size);
  104.     EXCL(ol.MemReqs,e.chip);
  105.     NEW(tmpRas);
  106. (*  rq.Assert((buffer # NIL) & (tmpRas # NIL),oom);   macht OberonLib v2.42 *)
  107.     g.InitTmpRas(tmpRas^,buffer,size);
  108.     rp.tmpRas := tmpRas;
  109.   END MakeTmpRas;
  110.  
  111.   PROCEDURE MakeArea (rp: g.RastPortPtr; maxvectors: INTEGER);
  112.     VAR areaInfo : g.AreaInfoPtr;
  113.         buffer   : e.ADDRESS;
  114.   BEGIN
  115.     ol.New(buffer,maxvectors * 5);
  116.     NEW(areaInfo);
  117.     g.InitArea(areaInfo^,buffer,maxvectors);
  118.     rp.areaInfo := areaInfo;
  119.   END MakeArea;
  120.  
  121. (*---------------------------------------------------------------------*)
  122.  
  123.   PROCEDURE Record;
  124.     VAR i,j: INTEGER;
  125.         prb: SHORTINT;
  126.         audci: SHORTINT;
  127.   BEGIN
  128.     (* $RangeChk- $OvflChk- $NilChk- *)
  129.  
  130.     audci := hw.aud0i + chan;
  131.  
  132.     (* Audio-Kanal für's Timing benutzen: *)
  133.  
  134.     hw.custom.intena := {audci};        (* Audio-Interrupt sperren *)
  135.  
  136.     hw.custom.aud[chan].ptr := NIL;
  137.     hw.custom.aud[chan].len := 1;       (* 1 Wort *)
  138.     hw.custom.aud[chan].per := 83;      (* Sampl.Freq = ca. 21 kHz *)
  139.     hw.custom.aud[chan].vol := 0;
  140.  
  141.     hw.custom.dmacon := {hw.aud0+chan}; (* DMA aus *)
  142.  
  143.     e.Disable;                          (* No interrupts, please *)
  144.  
  145.     hw.custom.intreq := {audci};
  146.     hw.custom.aud[chan].dat := 0;
  147.     prb := sys.VAL(SHORTINT,hw.ciaa.prb) + sys.VAL(SHORTINT,-128);
  148.      (* grrr, blöder Compiler, man muß ihn zwingen, zu glauben,
  149.         daß -128 noch SHORTINT ist :-( *)
  150.  
  151.     FOR i := 0 TO n-1 DO
  152.  
  153.       REPEAT UNTIL audci IN hw.custom.intreqr; (* Auf Audio-Interrupt warten *)
  154.       hw.custom.intreq := {audci};             (* Interrupt-Bit zurücksetzen *)
  155.       hw.custom.aud[chan].dat := 0;
  156.  
  157.       (* Parallel-Port lesen: *)
  158.  
  159.       prb := sys.VAL(SHORTINT,hw.ciaa.prb) + sys.VAL(SHORTINT,-128);
  160.  
  161.       xreal[i] := LONG(prb);
  162.  
  163.     END;
  164.  
  165.     e.Enable;
  166.  
  167.     (* Mit Hammingfunktion gewichten: *)
  168.  
  169.     FOR i := 0 TO n-1 DO
  170.       j := (i * (1024 DIV n) + 768) MOD 1024;
  171.       xreal[i] := xreal[i] * (sintab[j] DIV 512 + 64);
  172.       ximag[i] := 0;
  173.     END;
  174.  
  175.     (* $RangeChk= $OvflChk= $NilChk= *)
  176.  
  177.   END Record;
  178.  
  179. (*---------------------------------------------------------------------*)
  180.  
  181.   PROCEDURE Analyse;
  182.   BEGIN
  183.     FFT.FFT(xreal,ximag,n);  (* Fast-Fourier-Transform aufrufen *)
  184.     FFT.Abs(xreal,ximag,9);  (* Absolutwerte der komplexen Zahlen berechnen *)
  185.   END Analyse;
  186.  
  187. (*---------------------------------------------------------------------*)
  188.  
  189.   PROCEDURE Muls(x{0},y{1}: INTEGER): LONGINT; (* $EntryExitCode- *)
  190.   BEGIN
  191.     sys.INLINE(0C1C1H,04E75H);
  192.   END Muls;
  193.  
  194. (*---------------------------------------------------------------------*)
  195.  
  196.   PROCEDURE SetCols;
  197.  
  198.     TYPE
  199.       Eq = ARRAY 8 OF INTEGER;
  200.  
  201.     CONST
  202.       eq = Eq(64,256,297,341,384,427,469,512);  (* Equalizer: Alle Lampen
  203.                                                    sollen im Durchschnitt
  204.                                                    gleich hell sein *)
  205.     VAR
  206.       i,c: INTEGER;
  207.       s: SET;
  208.  
  209.   BEGIN
  210.     FOR i := 0 TO 7 DO
  211.       w := 0;
  212.       s := sys.VAL(SET,i);
  213.       IF s = {} THEN s := {0,2} END;
  214.       c := SHORT(ASH(Muls(xreal[i+1],eq[i]),shift));
  215.       IF c > 15 THEN c := 15 END;
  216.       IF c > hold[i] THEN hold[i] := c
  217.                      ELSE c := hold[i] END;
  218.       IF 0 IN s THEN INC(w,c) END; c := ASH(c,4);
  219.       IF 1 IN s THEN INC(w,c) END; c := ASH(c,4);
  220.       IF 2 IN s THEN INC(w,c) END;
  221.       col[i+4] := w;
  222.       DEC(hold[i]);
  223.     END;
  224.     g.LoadRGB4(vp,col,12);
  225.   END SetCols;
  226.  
  227. (*---------------------------------------------------------------------*)
  228.  
  229.   PROCEDURE MakeMenu(win: I.WindowPtr);
  230.   BEGIN
  231.     m.StartMenu(win);
  232.  
  233.     m.NewMenu("Projekt");
  234.     m.NewItem("Über...","U");
  235.     m.NewItem("Ende","E");
  236.  
  237.     m.NewMenu("Kanal");
  238.     m.NewItem("Links","L");
  239.     m.NewItem("Rechts","R");
  240.  
  241.     m.NewMenu("Pegel");
  242.     m.NewItem("Niedrig","1");
  243.     m.NewItem("Mittel","2");
  244.     m.NewItem("Hoch","3");
  245.  
  246.     menu := m.EndMenu();
  247.     IF I.SetMenuStrip(win,menu^) THEN END;
  248.   END MakeMenu;
  249.  
  250. (*---------------------------------------------------------------------*)
  251.  
  252.   PROCEDURE GetIMsg(win: I.WindowPtr; VAR mes: I.IntuiMessage);
  253.     VAR msg: I.IntuiMessagePtr;
  254.   BEGIN
  255.     msg := e.GetMsg(win.userPort);
  256.     IF msg # NIL THEN
  257.       mes := msg^;
  258.       e.ReplyMsg(msg)
  259.     ELSE
  260.       mes.class := LONGSET{}
  261.     END
  262.   END GetIMsg;
  263.  
  264. (*---------------------------------------------------------------------*)
  265.  
  266.   PROCEDURE Flag(s: LONGSET): INTEGER;
  267.     VAR i: INTEGER;
  268.   BEGIN
  269.     IF s = LONGSET{} THEN RETURN 0
  270.     ELSE i := -1; REPEAT INC(i) UNTIL i IN s; RETURN i END;
  271.   END Flag;
  272.  
  273. (*---------------------------------------------------------------------*)
  274.  
  275.   PROCEDURE HandleMessage(VAR mes: I.IntuiMessage);
  276.  
  277.     VAR
  278.       item: I.MenuItemPtr; itemNum:INTEGER; menuCode: INTEGER;
  279.  
  280.   BEGIN
  281.  
  282.     CASE Flag(mes.class) OF
  283.  
  284.     | 0:
  285.       RETURN;
  286.  
  287.     | I.closeWindow:
  288.       HALT(0);
  289.  
  290.     | I.menuPick:
  291.  
  292.       menuCode := mes.code;
  293.       WHILE menuCode # I.menuNull DO
  294.         item := I.ItemAddress(menu^,menuCode);
  295.         itemNum := I.ItemNum(menuCode);
  296.         CASE I.MenuNum(menuCode) OF
  297.  
  298.         | 0: (* Projekt *)
  299.  
  300.           CASE itemNum OF
  301.  
  302.           | 0: IF rq.RequestWin("Lichtorgel V1.0",
  303.                                 "© 92 by Christian Stiens",
  304.                                 ""," Ok ",win) THEN END;
  305.           | 1: HA