mirror of
https://github.com/erkyrath/infocom-zcode-terps.git
synced 2026-01-11 23:43:24 +00:00
578 lines
14 KiB
OpenEdge ABL
578 lines
14 KiB
OpenEdge ABL
|
|
{ sound driver for the Macintosh
|
|
WRITTEN BY: Duncan Blanchard 2-Feb-87 }
|
|
|
|
PROGRAM TestSound;
|
|
|
|
{ The first two switches are now specified in the command line that
|
|
invokes the compiler. Embedded names and range checking should be
|
|
suppressed in shipped code, but are useful for debugging. }
|
|
|
|
{cmdline $R-} { Turn on/off range checking }
|
|
{cmdline $D-} { Turn on/off procedure names in object code }
|
|
|
|
{ Exporting of names is off initially, then changed below. }
|
|
|
|
{$Z-} { do/don't export all routine names }
|
|
{$L-} { don't include lengthy interface files in listings }
|
|
USES
|
|
MemTypes,
|
|
QuickDraw,
|
|
OSIntf,
|
|
ToolIntf,
|
|
PackIntf;
|
|
{ MacPrint }
|
|
|
|
{$L+} { reenable listing for our code }
|
|
{$Z*} { export following (all) routine names (but not vars) }
|
|
|
|
TYPE
|
|
STR32 = STRING[32]; { parameters must be a simple type }
|
|
{ this is useless in Pascal; still sign-extends into longints }
|
|
{ UInteger = 0..65535; } { 16-bit unsigned }
|
|
UInteger = INTEGER; { just mask where necessary, sigh }
|
|
|
|
{ the following record def combines two adjacent byte members, because
|
|
of the vagaries of Pascal packing }
|
|
|
|
SHeader = PACKED RECORD { sound file header format: }
|
|
flen: UInteger; { len (bytes) of file following }
|
|
rp: UInteger; { repeat count / midi pitch }
|
|
rate: UInteger; { original sampling rate }
|
|
unused: UInteger;
|
|
dlen: UInteger { len (bytes) of data following }
|
|
END;
|
|
SHeaderPtr = ^SHeader;
|
|
|
|
CONST
|
|
ASHLEN = 10; { length, Activision sound header }
|
|
MSHLEN = 6; { length, Mac sound header }
|
|
MSLEN = MSHLEN + (64 * 1024); { max length, plus header }
|
|
|
|
VAR
|
|
sheadp: SHeaderPtr;
|
|
soundp: FFSynthPtr;
|
|
mfchan: INTEGER;
|
|
dfchan: INTEGER;
|
|
mpitch: Byte;
|
|
sreps: INTEGER;
|
|
sdone: BOOLEAN;
|
|
uservol: INTEGER; { user's original volume setting, 0..7 }
|
|
|
|
{-------------------------------}
|
|
{ SndFSOpen }
|
|
{-------------------------------}
|
|
|
|
{ This routine is a front end for FSOpen. Search for file, return
|
|
(1) chan and (2) status.
|
|
|
|
We expect sound files to be in a separate folder called 'Sound', itself
|
|
in the same folder (disk) as the game file. However, a Mac folder
|
|
may or may not be a true subdirectory. It's not under the old MFS,
|
|
which we might still run into on 400K disks and ramdisks. }
|
|
|
|
FUNCTION SndFSOpen (VAR name: STR32; VAR chan: INTEGER): OSErr;
|
|
VAR
|
|
name2: STR32;
|
|
err: OSErr;
|
|
BEGIN
|
|
name2 := concat (':Sound:', name); { use a partial pathname }
|
|
err := FSOpen (name2, 0, chan); { first look in subdir if any }
|
|
IF err <> 0 THEN
|
|
err := FSOpen (name, 0, chan); { then look in game dir }
|
|
|
|
IF err <> 0 THEN
|
|
chan := 0; { make sure it's marked as unopened }
|
|
SndFSOpen := err; { return status }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ InitMidi }
|
|
{-------------------------------}
|
|
|
|
{ open control file (combined midi & name files in Amiga format),
|
|
return (1) midi pitch and (2) data file name
|
|
|
|
If no control file exists, return default values. This lets us
|
|
purposely omit control files for many sounds. }
|
|
|
|
FUNCTION InitMidi (id: INTEGER; VAR dfname: STR32): OSErr;
|
|
CONST
|
|
MPADJUST = $18; { mystery pitch adjustment }
|
|
{ midi file offsets }
|
|
MFLEN = 0; { total length of triplets (normally 9) }
|
|
TRIPL1 = 2; { midi chan, pitch, vol }
|
|
TRIPL2 = 5;
|
|
TRIPL3 = 8;
|
|
MFMAX = 64; { max length of the above (let's say) }
|
|
{ name file offsets }
|
|
M1COUNT = 0; { number of data files (Mac: always 1) }
|
|
M1CHAN = 1;
|
|
M1NAME = 2; { name of first data file (asciz) }
|
|
|
|
VAR
|
|
idstr: STR255; { Pascal typing forces 255 }
|
|
mfname, temp: STR32;
|
|
mfdata: Packed Array [1..MFMAX] of SignedByte;
|
|
n: LONGINT;
|
|
mfln, i, err: INTEGER;
|
|
|
|
BEGIN
|
|
NumToString (id, idstr);
|
|
dfname := concat ('S', idstr); { default is Sn }
|
|
mpitch := $4A - MPADJUST; { default is $32 }
|
|
|
|
mfname := concat ('M', idstr);
|
|
err := SndFSOpen (mfname, mfchan); { search/open }
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitMidi := err;
|
|
EXIT (InitMidi);
|
|
END;
|
|
|
|
{ read in length of midi file }
|
|
n := 2;
|
|
err := FSRead (mfchan, n, @mfln);
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitMidi := err;
|
|
EXIT (InitMidi);
|
|
END;
|
|
IF mfln > MFMAX - 2 THEN { be safe }
|
|
BEGIN
|
|
InitMidi := -1;
|
|
EXIT (InitMidi);
|
|
END;
|
|
|
|
{ read in rest of midi file, plus start of name file }
|
|
n := mfln + 2;
|
|
err := FSRead (mfchan, n, @mfdata[1]);
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitMidi := err;
|
|
EXIT (InitMidi);
|
|
END;
|
|
|
|
{ read in name (of data file) }
|
|
n := 1;
|
|
i := 0;
|
|
REPEAT
|
|
i := i + 1;
|
|
err := FSRead (mfchan, n, @temp[i]);
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitMidi := err;
|
|
EXIT (InitMidi);
|
|
END;
|
|
UNTIL temp[i] = Chr (0);
|
|
temp[0] := Chr (i - 1);
|
|
|
|
dfname := temp; { return val }
|
|
mpitch := mfdata[2] - MPADJUST; { return val }
|
|
|
|
InitMidi := 0; { return 0 if all okay }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ CntCalc }
|
|
{-------------------------------}
|
|
|
|
{ sr = original sampling rate;
|
|
midv = desired midi pitch; refv = reference midi pitch
|
|
"count" = sr * (CHROMA ^ delta) * 44.93 / 1000000 }
|
|
|
|
FUNCTION CntCalc (sr: UInteger; midv, refv: SignedByte): Fixed;
|
|
VAR
|
|
val, base, base12: Fixed;
|
|
delta, i: SignedByte;
|
|
|
|
{ Note: fixed point constants are not possible since the format is
|
|
"known" only to the Toolbox, not the compiler. The constants below
|
|
could be computed once at startup for more speed.
|
|
CONST
|
|
CHROMA = 1.05946309; } { 12th root of 2 (equal-tempered scale) }
|
|
|
|
BEGIN { sr in range 9K..19K approx }
|
|
val := FixMul (FixRatio (sr,10000), FixRatio (4493,10000));
|
|
|
|
delta := midv - refv; { if zero, we're done }
|
|
IF delta > 0 THEN
|
|
base := FixRatio (10595,10000) { base := CHROMA; }
|
|
|
|
ELSE IF delta < 0 THEN
|
|
BEGIN
|
|
base := FixRatio (10000,10595); { base := 1 / CHROMA; }
|
|
delta := -delta;
|
|
END;
|
|
|
|
{ compute CHROMA ^ delta. Could use a lookup table for more speed. }
|
|
WHILE delta > 0 DO
|
|
BEGIN
|
|
val := FixMul (val, base);
|
|
delta := delta - 1;
|
|
END;
|
|
|
|
CntCalc := val;
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ InitData }
|
|
{-------------------------------}
|
|
|
|
{ open file, read sound data into global buffers }
|
|
|
|
FUNCTION InitData (VAR dfname: STR32): OSErr;
|
|
VAR
|
|
n: LONGINT; { len passed, actual len /returned/ here }
|
|
p: Ptr; { ptr to unsigned byte (see mem mgr) }
|
|
sr: UInteger;
|
|
dpitch: Byte;
|
|
err: OSErr;
|
|
|
|
BEGIN
|
|
err := SndFSOpen (dfname, dfchan); { search/open }
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitData := err;
|
|
EXIT (InitData);
|
|
END;
|
|
|
|
n := ASHLEN;
|
|
err := FSRead (dfchan, n, Ptr(sheadp)); { get data header }
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitData := err;
|
|
EXIT (InitData);
|
|
END;
|
|
|
|
n := BAND (sheadp^.dlen, $0FFFF); { 64K max, unsigned }
|
|
p := Ptr (ORD4(soundp) + MSHLEN); { leave space for Mac header }
|
|
err := FSRead (dfchan, n, p); { get data }
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitData := err;
|
|
EXIT (InitData);
|
|
END;
|
|
|
|
sr := sheadp^.rate;
|
|
dpitch := BAND (sheadp^.rp, $0FF); { extract low byte }
|
|
soundp^.count := CntCalc (sr, mpitch, dpitch);
|
|
soundp^.mode := ffMode; { free-form synthesizer }
|
|
|
|
InitData := 0; { all okay }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ InitCleanUp }
|
|
{-------------------------------}
|
|
|
|
PROCEDURE InitCleanUp; { just close any open files }
|
|
VAR
|
|
err: OSErr;
|
|
BEGIN
|
|
IF mfchan <> 0 THEN
|
|
err := FSClose (mfchan);
|
|
IF dfchan <> 0 THEN
|
|
err := FSClose (dfchan);
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ StartSnd, StopSnd }
|
|
{-------------------------------}
|
|
|
|
PROCEDURE StartActual; FORWARD;
|
|
|
|
PROCEDURE StartSnd (reps, zvol: INTEGER);
|
|
VAR
|
|
macvol, v: INTEGER; { zvol in 0..8, macvol in 0..7 }
|
|
BEGIN
|
|
IF zvol < 0 THEN { if -1, default to max }
|
|
zvol := 8;
|
|
v := uservol * zvol;
|
|
macvol := v DIV 8; { make proportional to user's setting }
|
|
IF (v MOD 8) > 0 THEN
|
|
macvol := macvol + 1; { round up (only 0 -> silence) }
|
|
|
|
SetSoundVol (macvol);
|
|
|
|
IF reps < 0 THEN { if -1, use midi val }
|
|
sreps := BAND (BSR (sheadp^.rp, 8), $0FF) { extract high byte }
|
|
ELSE
|
|
sreps := reps;
|
|
IF sreps = 0 THEN sreps := 8; { for now, "inf" = 8 ... }
|
|
|
|
sdone := FALSE;
|
|
StartActual;
|
|
END;
|
|
|
|
PROCEDURE StopSnd; { immed abort (could wait until end of cycle?) }
|
|
BEGIN
|
|
IF NOT sdone THEN
|
|
BEGIN
|
|
sdone := TRUE; { set flag }
|
|
StopSound; { THEN call -- also executes completion }
|
|
END;
|
|
|
|
SetSoundVol (uservol); { restore original setting }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ ComplSnd }
|
|
{-------------------------------}
|
|
|
|
{ completion routine for asynchronous sound driver call.
|
|
if reps-remaining count is positive, decrement it.
|
|
if it becomes zero, set "done" flag, otherwise start next loop. }
|
|
|
|
PROCEDURE ComplSnd;
|
|
BEGIN
|
|
SetUpA5; { since we're an interrupt, and use globals }
|
|
|
|
IF sreps > 0 THEN { if already zero, infinite loop }
|
|
BEGIN
|
|
sreps := sreps - 1;
|
|
IF sreps = 0 THEN { finished, set flag }
|
|
sdone := TRUE;
|
|
END;
|
|
|
|
IF NOT sdone THEN { not finished, begin next loop }
|
|
StartActual;
|
|
|
|
RestoreA5; { never call EXIT in this routine }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ StartActual }
|
|
{-------------------------------}
|
|
|
|
PROCEDURE StartActual;
|
|
VAR
|
|
n: LONGINT;
|
|
BEGIN
|
|
{ the "record len" parameter for a free-form synthesizer should
|
|
cover /only/ the data area and not the 6-byte header, despite
|
|
implications otherwise in IM. Otherwise the first few random bytes
|
|
following the data produce a nasty noise spike. }
|
|
|
|
{ n := BAND (sheadp^.dlen, $0FFFF) + MSHLEN; }
|
|
n := BAND (sheadp^.dlen, $0FFFF);
|
|
StartSound (Ptr(soundp), n, @ComplSnd);
|
|
END;
|
|
|
|
|
|
|
|
|
|
{-------------------------------}
|
|
{ GTAWord }
|
|
{-------------------------------}
|
|
|
|
{ pick up the word at the specified loc }
|
|
|
|
FUNCTION GTAWord (loc: LONGINT): INTEGER;
|
|
VAR p: ^INTEGER;
|
|
BEGIN
|
|
p := Pointer (loc);
|
|
GTAWord := p^;
|
|
|
|
(* This code, intended to pick up only a byte, still tries to read a word,
|
|
and crashes because of the odd address. Why?
|
|
VAR p: ^char;
|
|
p := Pointer ($400009);
|
|
IF char (p^) = char ($FF) THEN ...
|
|
*)
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ OnLisa }
|
|
{-------------------------------}
|
|
|
|
FUNCTION OnLisa: BOOLEAN; { check if running on Lisa [was in 68K] }
|
|
CONST
|
|
MACID = $400008; { magic ROM addr }
|
|
VAR id: INTEGER;
|
|
BEGIN
|
|
id := GTAWord (MACID); { machine id + ROM version }
|
|
|
|
IF BAND (id, $FF) = $FF { check /odd/ byte for Lisa-ness }
|
|
THEN OnLisa := TRUE { bingo }
|
|
ELSE OnLisa := FALSE;
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ OnMac2 }
|
|
{-------------------------------}
|
|
|
|
FUNCTION OnMac2: BOOLEAN;
|
|
CONST
|
|
ROM85 = $028E; { a different magic addr (in RAM) }
|
|
VAR id: INTEGER;
|
|
BEGIN
|
|
id := GTAWord (ROM85);
|
|
|
|
{ We want to write "IF id > $3FFF", but can't because the Pascal
|
|
comparison is signed ... }
|
|
|
|
IF (id = $FFFF) OR (id = $7FFF)
|
|
THEN OnMac2 := FALSE
|
|
ELSE OnMac2 := TRUE; { "Mac2 or later" }
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ BellSound }
|
|
{-------------------------------}
|
|
|
|
PROCEDURE BellSound (id: INTEGER); { beep or boop }
|
|
CONST
|
|
buffSize = 4;
|
|
VAR
|
|
swBuff: ARRAY [1..buffSize] OF INTEGER; { square wave rec, 1 element }
|
|
BEGIN
|
|
IF id = 1 THEN
|
|
BEGIN
|
|
SysBeep (8); { normal beep }
|
|
EXIT (BellSound);
|
|
END;
|
|
|
|
IF id = 2 THEN
|
|
BEGIN
|
|
IF OnLisa THEN
|
|
SysBeep (16) { Lisa's boop -- only certain way to make sound }
|
|
ELSE
|
|
(*** SysBeep (16); { Mac: but avoid MPW 1.0 sound driver bug } ***)
|
|
BEGIN { Mac: real boop }
|
|
swBuff[1] := swMode; { mode is square wave }
|
|
swBuff[2] := $B97; { middle C }
|
|
swBuff[3] := 128; { amplitude 0-255 }
|
|
swBuff[4] := 8; { duration in ticks }
|
|
StartSound (@swBuff, 2*buffSize, Ptr(-1));
|
|
END;
|
|
END;
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ ZSound }
|
|
{-------------------------------}
|
|
|
|
CONST
|
|
S_INIT = 1;
|
|
S_START = 2;
|
|
S_STOP = 3;
|
|
S_CLEANUP = 4;
|
|
|
|
VAR
|
|
lastID: INTEGER;
|
|
sInited, sStarted: BOOLEAN;
|
|
|
|
PROCEDURE ZSound (id, action, vol, reps: INTEGER);
|
|
VAR
|
|
dfname: STR32; { sound data file name }
|
|
err: INTEGER;
|
|
|
|
BEGIN
|
|
IF sheadp = NIL THEN { make sure buffers exist }
|
|
EXIT (ZSound);
|
|
IF soundp = NIL THEN
|
|
EXIT (ZSound);
|
|
|
|
IF (id = 1) OR (id = 2) THEN
|
|
BEGIN
|
|
BellSound (id); { beep/boop }
|
|
EXIT (ZSound);
|
|
END;
|
|
|
|
IF id = 0 THEN { use MRU effect }
|
|
BEGIN
|
|
IF lastID = 0 THEN { none, exit }
|
|
EXIT (ZSound)
|
|
ELSE id := lastID;
|
|
END
|
|
ELSE IF id <> lastID THEN { first clean up old, if any }
|
|
BEGIN
|
|
ZSound (lastID, S_CLEANUP, vol, reps); { (recurse) }
|
|
lastID := id;
|
|
END;
|
|
|
|
IF (action = S_INIT) OR (action = S_START) THEN
|
|
IF NOT sInited THEN
|
|
BEGIN
|
|
err := InitMidi (id, dfname); { if error, just use defaults }
|
|
err := InitData (dfname);
|
|
IF err <> 0 THEN
|
|
BEGIN
|
|
InitCleanUp; { Mac: close files immed }
|
|
EXIT (ZSound);
|
|
END;
|
|
sInited := TRUE;
|
|
END;
|
|
|
|
IF action = S_START THEN
|
|
BEGIN
|
|
StopSnd; { Mac: reset if in middle }
|
|
StartSnd (vol, reps);
|
|
sStarted := TRUE;
|
|
END;
|
|
|
|
IF (action = S_STOP) OR (action = S_CLEANUP) THEN
|
|
IF sStarted THEN
|
|
BEGIN
|
|
StopSnd;
|
|
sStarted := FALSE;
|
|
END;
|
|
|
|
IF action = S_CLEANUP THEN
|
|
BEGIN
|
|
IF sInited THEN
|
|
BEGIN
|
|
InitCleanUp;
|
|
sInited := FALSE;
|
|
END;
|
|
lastID := 0; { back to original state }
|
|
END;
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ ZEndSound }
|
|
{-------------------------------}
|
|
|
|
{ called from 68K, returns TRUE to report end of last sound }
|
|
|
|
FUNCTION ZEndSound: BOOLEAN;
|
|
BEGIN
|
|
ZEndSound := sdone;
|
|
END;
|
|
|
|
{-------------------------------}
|
|
{ Main }
|
|
{-------------------------------}
|
|
|
|
BEGIN
|
|
MoreMasters;
|
|
InitGraf (@thePort);
|
|
InitWindows;
|
|
InitFonts;
|
|
InitMenus;
|
|
InitCursor;
|
|
FlushEvents (everyEvent,0);
|
|
|
|
{ one-time allocation of buffers for sound data }
|
|
sheadp := SHeaderPtr (NewPtr(ASHLEN));
|
|
soundp := FFSynthPtr (NewPtr(MSLEN));
|
|
|
|
mfchan := 0; { mark as unopened }
|
|
dfchan := 0;
|
|
|
|
lastID := 0;
|
|
sInited := FALSE;
|
|
sStarted := FALSE;
|
|
|
|
GetSoundVol (uservol); { remember user's setting }
|
|
|
|
ZSound (99, S_START, -1, -1);
|
|
WHILE NOT ZEndSound DO { for now, just busy loop ... }
|
|
BEGIN
|
|
END;
|
|
ZSound (99, S_CLEANUP, -1, -1);
|
|
|
|
END.
|
|
|