language-Modula2-0.1: examples/Modula-2_Libraries/PMOS/sources/util/plink.mod
MODULE Plink;
(********************************************************)
(* *)
(* Allows the user to test the effect of *)
(* adjustable music parameters on the sound, *)
(* by trial and error from the keyboard. *)
(* *)
(* Programmer: P. Moylan *)
(* Last edited: 21 March 1995 *)
(* Status: Working *)
(* The "model 1" approach needs major improvements *)
(* *)
(********************************************************)
FROM Windows IMPORT
(* type *) Window, Colour, FrameType, DividerType,
(* proc *) OpenWindow, SetCursor, WriteLn, WriteString, ColourSwap;
FROM NumericIO IMPORT
(* proc *) WriteRJCard, EditCardinal;
FROM Keyboard IMPORT
(* proc *) InKey, PutBack;
FROM Play3 IMPORT
(* const*) CycleCount,
(* type *) WaveNumber, GainType, WaveGroup, EnvelopeArrayIndex,
(* proc *) DefineWaveform, DefineEnvelope, Play;
FROM MATHLIB IMPORT
(* proc *) Sin, Cos, Exp;
FROM Storage1 IMPORT
(* proc *) ALLOCATE;
(************************************************************************)
TYPE
VarRange = [0..6];
VAR
(* Waveform table pointers. *)
Wave: ARRAY WaveNumber OF WaveGroup;
(* Array to define the attack/decay envelope. *)
Envelope: ARRAY EnvelopeArrayIndex OF GainType;
(* Where the music is stored. We also use part of the MainVoice *)
(* array for temporary storage of data. *)
MainVoice: ARRAY [0..7] OF CARDINAL;
NullVoice: ARRAY [0..0] OF CARDINAL;
(* Some variables whose values will be adjusted from the keyboard. *)
attack, decay, sustain: CARDINAL;
(* Envelope generation model. *)
Model: [0..1];
(* Map that tells us how to access the variables that can be *)
(* changed from the keyboard. *)
VarMap: ARRAY VarRange OF
RECORD
address: POINTER TO CARDINAL;
max: CARDINAL;
END (*RECORD*);
(************************************************************************)
(* ENVELOPE CALCULATIONS *)
(************************************************************************)
PROCEDURE EnvelopeModel0 (Attack, Decay, Sustain: LONGREAL);
(* Calculates the envelope array using an attack/decay/sustain model.*)
CONST scaletogain = LONGREAL(MAX(GainType));
VAR level: LONGREAL;
phase: [0..1]; j: EnvelopeArrayIndex;
BEGIN
Decay := 1.0 - Decay;
phase := 0; level := 0.0;
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
IF phase = 0 THEN
(* Attack phase: ramp up linearly to maximum. *)
level := level + Attack;
IF level > 1.0 THEN
level := 1.0; INC(phase);
END(*IF*);
ELSE
(* Decay phase: we're using an exponential decay. *)
level := Sustain + Decay*(level - Sustain);
END (*IF*);
Envelope[j] := VAL(GainType, scaletogain*level);
END (*FOR*);
END EnvelopeModel0;
(************************************************************************)
PROCEDURE OldEnvelopeModel1 (alpha, beta, steady: LONGREAL);
(* Calculates the envelope array using a second order dynamic model.*)
(* This model is not yet working well, apparently because I'm not *)
(* working with a useful range of parameters. *)
CONST small = 1.0E-20;
VAR state: ARRAY [0..1] OF LONGREAL;
nextstate: LONGREAL; j: EnvelopeArrayIndex;
Result: ARRAY EnvelopeArrayIndex OF LONGREAL;
min, max, scale: LONGREAL;
BEGIN
min := 0.0; max := 0.0;
(* Map alpha and beta to the stable range: alpha from -2.0 to *)
(* +2.0, and beta from -1.0 to 1.0-ABS(alpha). *)
alpha := 4.0*alpha - 2.0;
beta := (2.0 - ABS(alpha))*beta - 1.0;
state[0] := -steady; state[1] := -steady;
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
Result[j] := state[1] + steady;
IF Result[j] < min THEN min := Result[j]
ELSIF Result[j] > max THEN max := Result[j]
END (*IF*);
nextstate := alpha*state[1] + beta*state[0];
state[0] := state[1];
state[1] := nextstate;
END (*FOR*);
(* Now scale the results to fit into the desired range. *)
IF ABS(max-min) < small THEN
Envelope[0] := 0;
FOR j := 1 TO MAX(EnvelopeArrayIndex) DO
Envelope[j] := MAX (GainType);
END (*FOR*);
ELSE
scale := LONGREAL(MAX(GainType))/(max - min);
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
Envelope[j] := VAL (GainType, scale*(Result[j] - min));
END (*FOR*);
END (*IF*);
END OldEnvelopeModel1;
(************************************************************************)
PROCEDURE EnvelopeModel1 (A, D, steady: LONGREAL);
(* Calculates the envelope array using a second order dynamic model.*)
(* This model is not yet working well, apparently because I'm not *)
(* working with a useful range of parameters. *)
CONST small = 1.0E-20;
scaleA = 10.0; scaleD = 0.5;
VAR j: EnvelopeArrayIndex;
Result: ARRAY EnvelopeArrayIndex OF LONGREAL;
min, max, scale: LONGREAL;
t, deltat: LONGREAL;
K1, K2, K3, alpha: LONGREAL;
BEGIN
min := 0.0; max := 0.0;
K1 := steady; K2 := -K1;
deltat := 0.2;
alpha := scaleD*D;
K3 := scaleA*A + alpha*K2;
t := 0.0;
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
Result[j] := K1 + Exp(-alpha*t)*(K2*Cos(t) + K3*Sin(t));
IF Result[j] < min THEN min := Result[j]
ELSIF Result[j] > max THEN max := Result[j]
END (*IF*);
t := t + deltat;
END (*FOR*);
(* Now scale the results to fit into the desired range. *)
scale := LONGREAL(MAX(GainType))/(max-min);
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
Envelope[j] := VAL (GainType, scale*(Result[j]-min));
END (*FOR*);
END EnvelopeModel1;
(************************************************************************)
PROCEDURE UpdateEnvelope;
(* Turns the current envelope parameters into an envelope array. *)
CONST scaletoreal = 1.0/LONGREAL(MAX(CARDINAL));
VAR Attack, Decay, Sustain: LONGREAL;
BEGIN
Attack := scaletoreal*LONGREAL(attack);
Decay := scaletoreal*LONGREAL(decay);
Sustain := scaletoreal*LONGREAL(sustain);
IF Model = 0 THEN EnvelopeModel0 (Attack, Decay, Sustain);
ELSE EnvelopeModel1 (Attack, Decay, Sustain);
END (*IF*);
END UpdateEnvelope;
(************************************************************************)
PROCEDURE ShowEnvelope (w: Window);
(* Displays the current envelope. *)
VAR j: EnvelopeArrayIndex;
BEGIN
SetCursor (w, 2, 1);
FOR j := 0 TO MAX(EnvelopeArrayIndex) DO
WriteRJCard (w, Envelope[j], 6);
END (*FOR*);
END ShowEnvelope;
(************************************************************************)
(* SCREEN EDITING *)
(************************************************************************)
PROCEDURE EditValue (w: Window; N: VarRange; fieldsize: CARDINAL);
(* Allows direct entry of the value of variable number N from the *)
(* keyboard. *)
VAR value: CARDINAL;
BEGIN
WITH VarMap[N] DO
value := address^;
EditCardinal (w, value, fieldsize);
IF value > max THEN value := max END(*IF*);
address^ := value;
END (*WITH*);
END EditValue;
(************************************************************************)
PROCEDURE AdjustValue (N: VarRange; amount: INTEGER);
(* Changes the value of variable number N by the given amount, with *)
(* wraparound. We clip "amount" in the case where the value *)
(* specified is inappropriately large relative to the maximum *)
(* allowed value of variable number N. *)
VAR value, max, absamount: CARDINAL; halfmax: INTEGER;
BEGIN
max := VarMap[N].max;
IF max < MAX(CARDINAL) THEN
IF max = 1 THEN halfmax := 1
ELSE halfmax := max DIV 2;
END (*IF*);
IF amount > halfmax THEN amount := halfmax
ELSIF amount < -halfmax THEN amount := -halfmax
END (*IF*);
END (*IF*);
value := VarMap[N].address^;
IF amount > 0 THEN
absamount := amount;
IF value <= max - absamount THEN
value := value + absamount;
ELSE
value := value - (max - absamount + 1);
END (*IF*);
ELSE
absamount := -amount;
IF value >= absamount THEN
value := value - absamount;
ELSE
value := value + (max - absamount + 1);
END (*IF*);
END (*IF*);
VarMap[N].address^ := value;
END AdjustValue;
(************************************************************************)
PROCEDURE DoTheTests;
TYPE CharSet = SET OF CHAR;
CONST
Esc = CHR(27); Digits = CharSet {'0'..'9'};
userrow = 6; colbase = 10; fieldwidth = 5; gap = 4;
VAR w, EW: Window; ch: CHAR;
N: VarRange; value: CARDINAL;
(********************************************************************)
PROCEDURE Highlight;
(* Swaps the screen colour for field N. *)
BEGIN
ColourSwap (w, userrow, colbase + (fieldwidth+gap)*N, fieldwidth);
END Highlight;
(********************************************************************)
PROCEDURE PositionCursor (N: VarRange);
(* Sets the screen cursor to the position of variable N. *)
BEGIN
SetCursor (w, userrow, colbase + (fieldwidth+gap)*N);
END PositionCursor;
(********************************************************************)
PROCEDURE WriteValue (N: VarRange);
(* Writes the value for field N to the screen. *)
BEGIN
PositionCursor (N);
WriteRJCard (w, VarMap[N].address^, fieldwidth);
END WriteValue;
(********************************************************************)
BEGIN
OpenWindow (EW, black, white, 17, 24, 0, 79, simpleframe, nodivider);
WriteString (EW, "Envelope:");
OpenWindow (w, black, green, 8, 16, 0, 79, noframe, nodivider);
WriteLn (w);
WriteString (w, " Cursor right/left to select variable,");
WriteString (w, " up/down to change value,");
WriteLn (w);
WriteString (w, " PgUp/PgDown for coarse changes, Space to");
WriteString (w, " play note, Esc to exit");
SetCursor (w, userrow-2, colbase-1);
WriteString (w, "Duration Frequency Waveform Attack Decay");
WriteString (w, " Sustain Model");
SetCursor (w, userrow, colbase);
FOR N := 0 TO 6 DO
WriteValue (N);
END (*FOR*);
N := 0;
LOOP
UpdateEnvelope; ShowEnvelope (EW);
Highlight;
ch := InKey();
Highlight;
IF ch = Esc THEN
EXIT (*LOOP*);
ELSIF ch = " " THEN
Play (MainVoice, NullVoice, NullVoice);
ELSIF ch IN Digits THEN
PositionCursor (N);
PutBack (ch);
EditValue (w, N, fieldwidth);
WriteValue (N);
ELSIF ch = CHR(0) THEN
ch := InKey();
IF ch = "H" THEN (* cursor up *)
AdjustValue (N, 1);
WriteValue (N);
ELSIF ch = "P" THEN (* cursor down *)
AdjustValue (N, -1);
WriteValue (N);
ELSIF ch = "I" THEN (* page up *)
AdjustValue (N, 250);
WriteValue (N);
ELSIF ch = "Q" THEN (* page down *)
AdjustValue (N, -250);
WriteValue (N);
ELSIF ch = "M" THEN (* cursor right *)
IF N = MAX(VarRange) THEN N := 0
ELSE INC(N);
END (*IF*);
ELSIF ch = "K" THEN (* cursor left *)
IF N = 0 THEN N := MAX(VarRange)
ELSE DEC(N);
END (*IF*);
END (*IF*);
END (*IF*);
END (*LOOP*);
END DoTheTests;
(************************************************************************)
(* MODULE INITIALISATION *)
(************************************************************************)
PROCEDURE Initialise;
CONST
PI = 3.141592653589793240;
offset = LONGREAL(128*CycleCount-1) / 3.0;
bound = 2.0*offset; (* limit on peak-to-peak value *)
VAR scale: LONGREAL;
j, break: SHORTCARD;
w: WaveNumber;
v: VarRange;
g: GainType;
Gain: ARRAY GainType OF LONGREAL;
(********************************************************************)
PROCEDURE WaveValue (w: WaveNumber; pos: BYTE; val: LONGREAL);
(* Is passed the value for maximum sound, fills in the tables *)
(* with all the scaled values. *)
VAR g: GainType;
BEGIN
FOR g := 0 TO MAX(GainType) DO
Wave[w][g]^[pos] := VAL(INTEGER, val*Gain[g]);
END;
END WaveValue;
(********************************************************************)
BEGIN
(* Create the waveform arrays. *)
FOR g := 0 TO MAX(GainType) DO
Gain[g] := LONGREAL(g)/LONGREAL(MAX(GainType));
FOR w := 0 TO HIGH(Wave) DO
NEW (Wave[w][g]);
END (*FOR*);
END (*FOR*);
(* Waveform #0: sine wave. *)
(* Waveform #1: sine wave + 3rd harmonic. *)
FOR j := 0 TO 255 DO
WaveValue (0, j, 0.5*bound*Sin(VAL(LONGREAL,j)*PI/128.0));
WaveValue (1, j, 0.56*bound*(Sin(VAL(LONGREAL,j)*PI/128.0)
+ 0.18*Sin(3.0*VAL(LONGREAL,j)*PI/128.0)));
END (*FOR*);
(* Waveforms #2, 3, 4: rectangular waves. *)
FOR w := 2 TO 4 DO
break := 56*SHORTCARD(w) + 16;
FOR j := 0 TO break-1 DO
WaveValue (w, j, offset);
END (*FOR*);
FOR j := break TO 255 DO
WaveValue (w, j, -offset);
END (*FOR*);
END (*FOR*);
(* Waveforms #5, 6, 7: triangular waves. *)
FOR w := 5 TO 6 DO
break := VAL(SHORTCARD, 64*w - 192);
scale := bound/LONGREAL(break);
FOR j := 0 TO break-1 DO
WaveValue (w,j, scale*LONGREAL(j)-offset);
END (*FOR*);
scale := bound/LONGREAL(256-CARDINAL(break));
FOR j := break TO 255 DO
WaveValue (w, j, scale*LONGREAL(256-CARDINAL(j))-offset);
END (*FOR*);
END (*FOR*);
FOR j := 0 TO 255 DO
WaveValue (7, j, bound*LONGREAL(j)/256.0-offset);
END (*FOR*);
(* Pass the waveforms and envelope address to the subsidiary *)
(* module. *)
FOR w := 0 TO 7 DO
DefineWaveform (w, Wave[w]);
END (*FOR*);
DefineEnvelope (0, ADR(Envelope));
(* Put some code in the Voice arrays. *)
MainVoice[0] := 65534;
MainVoice[1] := 300; (* Duration *)
MainVoice[2] := 65532;
MainVoice[3] := 2; (* Waveform number *)
MainVoice[4] := 65531;
MainVoice[5] := 0; (* Envelope number *)
MainVoice[6] := 2750; (* note code *)
MainVoice[7] := 65535;
NullVoice[0] := 65535;
(* Set up the VarMap array. *)
FOR v := 0 TO MAX(VarRange) DO
VarMap[v].max := MAX(CARDINAL);
END (*FOR*);
VarMap[2].max := MAX(WaveNumber);
VarMap[6].max := 1;
VarMap[0].address := ADR(MainVoice[1]); (* Duration *)
VarMap[1].address := ADR(MainVoice[6]); (* Note code *)
VarMap[2].address := ADR(MainVoice[3]); (* Waveform number *)
VarMap[3].address := ADR(attack); (* attack *)
VarMap[4].address := ADR(decay); (* decay *)
VarMap[5].address := ADR(sustain); (* sustain *)
VarMap[6].address := ADR(Model); (* model *)
(* Give initial values to some other global variables. *)
Model := 1;
attack := 65535;
decay := 2000;
sustain := 32768;
END Initialise;
(************************************************************************)
BEGIN
Initialise;
DoTheTests;
END Plink.