home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Da Capo
/
da_capo_vol1.bin
/
programs
/
amiga
/
misc
/
lichtorgel
/
lichtorgel.mod
< prev
next >
Wrap
Text File
|
1980-01-11
|
12KB
|
452 lines
(*---------------------------------------------------------------------------
:Program. Lichtorgel.mod
:Contents. Simulation einer 8-Kanal Lichtorgel
:Author. Christian Stiens
:Address. Heustiege 2, W-4710 Lüdinghausen
:Copyright. Freeware, All Rights Reserved, © 1992 by cs-soft
:Language. Oberon-2
:Translator. Amiga Oberon V2.42d (inofficial ß-version)
:History. V1.0, 07-Sep-92
:Imports. Menu (AMOK #59), FFT (AMOK #68)
---------------------------------------------------------------------------*)
(* $StackChk- weil wenig lokale Variablen und keine Rekursion *)
MODULE Lichtorgel;
IMPORT
au := Audio,
e := Exec,
es := ExecSupport,
FFT,
g := Graphics,
hw := Hardware,
I := Intuition,
Misc,
m := Menu,
rq := Requests,
ol := OberonLib,
sys:= SYSTEM;
CONST
ver = "\o$VER: lichtorgel 1.0 (7.9.92)\n\r";
oom = "Speichermangel";
CONST
n = 16; (* 16 Punkt FFT *)
VAR
nw : I.NewWindow;
win : I.WindowPtr;
scr : I.ScreenPtr;
menu : I.MenuPtr;
ioa : au.IOAudioPtr;
mes : I.IntuiMessage;
pp,pb : e.APTR;
chan : SHORTINT;
col : ARRAY 16 OF INTEGER;
i,w,x,y : INTEGER;
shift : INTEGER;
rp : g.RastPortPtr;
vp : g.ViewPortPtr;
hold : ARRAY 8 OF INTEGER;
xreal,
ximag : ARRAY n OF INTEGER;
sintab ["_sintab_1024x16"] : ARRAY 1024 OF INTEGER;
(*---------------------------------------------------------------------*)
TYPE InitProc = PROCEDURE(ioReq: e.MessagePtr);
PROCEDURE OpenDev (name : ARRAY OF CHAR;
unit : LONGINT;
flags : LONGSET;
ioSize : INTEGER;
ioInit : InitProc): e.MessagePtr; (* $CopyArrays- *)
VAR
port: e.MsgPortPtr;
ioReq: e.IORequestPtr;
BEGIN
port := es.CreatePort("",0);
IF port = NIL THEN RETURN NIL END;
IF ioSize = 0 THEN ioSize := SIZE(e.IOStdReq) END;
ioReq := es.CreateExtIO(port,ioSize);
IF ioReq = NIL THEN es.DeletePort(port); RETURN NIL END;
IF ioInit # NIL THEN ioInit(ioReq) END;
IF e.OpenDevice(name,unit,ioReq,flags) # 0 THEN
es.DeleteExtIO(ioReq);
es.DeletePort(port);
RETURN NIL
END;
RETURN ioReq;
END OpenDev;
PROCEDURE CloseDev (ioReq: e.MessagePtr);
VAR port: e.MsgPortPtr;
BEGIN
port := ioReq.replyPort;
e.CloseDevice(ioReq);
es.DeleteExtIO(ioReq);
es.DeletePort(port);
END CloseDev;
(*---------------------------------------------------------------------*)
PROCEDURE MakeTmpRas (rp: g.RastPortPtr);
VAR tmpRas : g.TmpRasPtr;
buffer : e.ADDRESS;
size : LONGINT;
BEGIN
size := LONG(rp.bitMap.bytesPerRow) * LONG(rp.bitMap.rows);
INCL(ol.MemReqs,e.chip);
ol.New(buffer,size);
EXCL(ol.MemReqs,e.chip);
NEW(tmpRas);
(* rq.Assert((buffer # NIL) & (tmpRas # NIL),oom); macht OberonLib v2.42 *)
g.InitTmpRas(tmpRas^,buffer,size);
rp.tmpRas := tmpRas;
END MakeTmpRas;
PROCEDURE MakeArea (rp: g.RastPortPtr; maxvectors: INTEGER);
VAR areaInfo : g.AreaInfoPtr;
buffer : e.ADDRESS;
BEGIN
ol.New(buffer,maxvectors * 5);
NEW(areaInfo);
g.InitArea(areaInfo^,buffer,maxvectors);
rp.areaInfo := areaInfo;
END MakeArea;
(*---------------------------------------------------------------------*)
PROCEDURE Record;
VAR i,j: 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 := 83; (* Sampl.Freq = ca. 21 kHz *)
hw.custom.aud[chan].vol := 0;
hw.custom.dmacon := {hw.aud0+chan}; (* DMA aus *)
e.Disable; (* No interrupts, please *)
hw.custom.intreq := {audci};
hw.custom.aud[chan].dat := 0;
prb := sys.VAL(SHORTINT,hw.ciaa.prb) + sys.VAL(SHORTINT,-128);
(* grrr, blöder Compiler, man muß ihn zwingen, zu glauben,
daß -128 noch SHORTINT ist :-( *)
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 := 0;
(* 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
j := (i * (1024 DIV n) + 768) MOD 1024;
xreal[i] := xreal[i] * (sintab[j] 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,9); (* Absolutwerte der komplexen Zahlen berechnen *)
END Analyse;
(*---------------------------------------------------------------------*)
PROCEDURE Muls(x{0},y{1}: INTEGER): LONGINT; (* $EntryExitCode- *)
BEGIN
sys.INLINE(0C1C1H,04E75H);
END Muls;
(*---------------------------------------------------------------------*)
PROCEDURE SetCols;
TYPE
Eq = ARRAY 8 OF INTEGER;
CONST
eq = Eq(64,256,297,341,384,427,469,512); (* Equalizer: Alle Lampen
sollen im Durchschnitt
gleich hell sein *)
VAR
i,c: INTEGER;
s: SET;
BEGIN
FOR i := 0 TO 7 DO
w := 0;
s := sys.VAL(SET,i);
IF s = {} THEN s := {0,2} END;
c := SHORT(ASH(Muls(xreal[i+1],eq[i]),shift));
IF c > 15 THEN c := 15 END;
IF c > hold[i] THEN hold[i] := c
ELSE c := hold[i] END;
IF 0 IN s THEN INC(w,c) END; c := ASH(c,4);
IF 1 IN s THEN INC(w,c) END; c := ASH(c,4);
IF 2 IN s THEN INC(w,c) END;
col[i+4] := w;
DEC(hold[i]);
END;
g.LoadRGB4(vp,col,12);
END SetCols;
(*---------------------------------------------------------------------*)
PROCEDURE MakeMenu(win: I.WindowPtr);
BEGIN
m.StartMenu(win);
m.NewMenu("Projekt");
m.NewItem("Über...","U");
m.NewItem("Ende","E");
m.NewMenu("Kanal");
m.NewItem("Links","L");
m.NewItem("Rechts","R");
m.NewMenu("Pegel");
m.NewItem("Niedrig","1");
m.NewItem("Mittel","2");
m.NewItem("Hoch","3");
menu := m.EndMenu();
IF I.SetMenuStrip(win,menu^) THEN END;
END MakeMenu;
(*---------------------------------------------------------------------*)
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 Flag(s: LONGSET): INTEGER;
VAR i: INTEGER;
BEGIN
IF s = LONGSET{} THEN RETURN 0
ELSE i := -1; REPEAT INC(i) UNTIL i IN s; RETURN i END;
END Flag;
(*---------------------------------------------------------------------*)
PROCEDURE HandleMessage(VAR mes: I.IntuiMessage);
VAR
item: I.MenuItemPtr; itemNum:INTEGER; menuCode: INTEGER;
BEGIN
CASE Flag(mes.class) OF
| 0:
RETURN;
| I.closeWindow:
HALT(0);
| I.menuPick:
menuCode := mes.code;
WHILE menuCode # I.menuNull DO
item := I.ItemAddress(menu^,menuCode);
itemNum := I.ItemNum(menuCode);
CASE I.MenuNum(menuCode) OF
| 0: (* Projekt *)
CASE itemNum OF
| 0: IF rq.RequestWin("Lichtorgel V1.0",
"© 92 by Christian Stiens",
""," Ok ",win) THEN END;
| 1: HA