program LOAD;
{$D KC-Load 0.XX (02/00)}
{$C MOVEABLE PRELOAD PERMANENT}
{$R KCLOAD.RES}
uses
WinTypes, WinProcs, Win31, MMSystem, CommDlg{, ShellApi},
WUtils;
const
RegPath='KCEMU\KCLOAD';
HelpFileName='KCLOAD.HLP';
UserDllFilter='*.KCL';
WaveFileName='KCLOAD.WAV';
var
hWav: HWaveIn; {für Ein- und Ausgabe (erfolgt nie gleichzeitig)}
Waves: array[0..1] of THandle;
Modus: Integer; {0=frei, 1=LOADing, 2=SAVEteimas}
{Gespeicherte Setup-Daten (Registry), MÜSSEN HINTEREINANDER LIEGEN BLEIBEN}
Retries: Integer; {Anzahl Wiederholungen beim Lesen}
Coding: Integer; {Modus KC normal, Turbo MPM, Turbo h#s, Z1013}
WaveVol: Integer; {Lautstärke-Multiplikator (log.) bei Ausgabe}
WaveInDev, WaveOutDev: Integer;
{Nummer des Ein- bzw. Ausgabegerätes}
Installed: Boolean;
BytesToWrite: LongInt;
BufPtr: LongInt;
AppName: array[0..31] of Char;
CurWaveHdr: PWaveHdr; {ZeigerZeiger auf momentan zu prozessierende Daten}
Task: THandle;
LibInst: THandle; {Geladene KCL-Bibliothek}
Back: HBrush; {Hintergrundpinsel für Statuszeile (Blau)}
type
TWaveFileHdr=record {Header der WAVE-Datei}
riff: array[0..3] of Char;
rlen: LongInt; {Offset 4, enthält filesize-8}
wave,fmt: array[0..3] of Char;
flen: LongInt;
MyWav: TPCMWaveFormat;
data: array[0..3] of Char;
dlen: LongInt; {Offset 28h, enthält filesize-2Ch}
end;
const
WAVBLK=$4000; {je größer, desto weniger Aussetzer, aber asynchroner}
WaveFileHdr: TWaveFileHdr=(
riff: 'RIFF';
rlen: -1;
wave: 'WAVE';
fmt : 'fmt ';
flen: sizeof(TPCMWaveFormat); {10h}
MyWav:(
wf:(
wFormatTag: WAVE_Format_PCM;
nChannels: 1;
nSamplesPerSec: 22050;
nAvgBytesPerSec: 22050;
nBlockAlign: 1);
wBitsPerSample: 8);
data: 'DATA';
dlen: -1);
WM_ContinueInit=WM_User+10;
WM_EndProcess=WM_User+11;
WM_SetStatus=WM_User+12;
WM_ReportWaveError=WM_User+13;
type
TBlock=array[0..127] of Byte;
TCallProc=procedure; {Formatabhängige Lese/Schreibfunktion}
TS255=array[0..255] of Char;
TS31=array[0..31] of Char;
var
MainWnd: HWnd; {Global ist besser im Zugriff!}
hBuffer: THandle; {Speicherabbild der Datei, Wachstum durch Verdopplung}
{ S: array[byte]of Char;}
ByteIndex: Word;
Amp: ShortInt;
procedure EndProcess1(OK:Boolean); forward;
function SaveFile:Boolean; forward;
procedure FreeWaveBlock(var M:THandle); forward;
function GetFileName(S,buf:PChar):integer; forward;
procedure SetStat(S:PChar);
begin
PostMessage(MainWnd,WM_SetStatus,0,LongInt(S));
end;
function GetSize:LongInt;
begin
case Modus of
1: GetSize:=BufPtr;
2: GetSize:=BytesToWrite-BufPtr;
end;
end;
function GetData(P:PChar; Size:Integer):Integer;
var
Buf: PChar;
begin
Buf:=GlobalLock(hBuffer);
IncHPL(Buf,BufPtr);
if Size>BytesToWrite-BufPtr then Size:=BytesToWrite-BufPtr;
hmemcpy(P,Buf,Size);
Inc(BufPtr,Size);
GetData:=Size;
GlobalUnlock(hBuffer);
end;
procedure AddData(P:PChar; Size:Integer);
var
Buf: PChar;
begin
if BufPtr+Size>GlobalSize(hBuffer) then begin
hBuffer:=GlobalReAlloc(hBuffer,GlobalSize(hBuffer) shl 1,0);
if hBuffer=0 then EndProcess1(false); {sollte nie passieren}
end;
Buf:=GlobalLock(hBuffer);
IncHPL(Buf,BufPtr);
hmemcpy(Buf,P,Size);
Inc(BufPtr,Size);
GlobalUnlock(hBuffer);
end;
procedure ProcessBlock;
{Kontext: MMTASK.TSK}
var
Msg: TMsg;
begin
with CurWaveHdr^ do case Modus of
1: begin
if WaveInDev=-2 then begin
LongRec(dwBytesRecorded).Lo:=
_lread(hWav,lpData,LongRec(dwBufferLength).Lo);
if LongRec(dwBytesRecorded).Lo=0 then EndProcess1(false);
PeekMessage(Msg,0,0,0,PM_Remove); {Windows zum Zug kommen lassen}
if Msg.message=WM_Quit then EndProcess1(false);
end else begin
WaveInAddBuffer(hWav,CurWaveHdr,sizeof(TWaveHdr)); {leeren Puffer hinein}
if not GetMessage(Msg,0,0,0) then EndProcess1(false);
{gibt Rechenzeit frei}
{$IFOPT D+} if Msg.message<>MM_WIM_Data then asm int 3 end; {$ENDIF}
CurWaveHdr:=Pointer(Msg.lParam); {Neuer Block, gefüllt mit Daten, steht bereit}
end;
ByteIndex:=0; {Lesezeiger}
end;
2: begin
if WaveOutDev=-2 then begin
if _lwrite(hWav,CurWaveHdr^.lpData,
LongRec(CurWaveHdr^.dwBufferLength).Lo)<>
LongRec(CurWaveHdr^.dwBufferLength).Lo
then EndProcess1(false);
PeekMessage(Msg,0,0,0,PM_Remove); {Windows zum Zug kommen lassen}
if Msg.message=WM_Quit then EndProcess1(false);
end else begin
WaveOutWrite(hWav,CurWaveHdr,sizeof(TWaveHdr)); {vollen Puffer hinein}
if not GetMessage(Msg,0,0,0) then EndProcess1(false);
{gibt Rechenzeit frei}
{$IFOPT D+} if Msg.message<>MM_WOM_Done then asm int 3 end; {$ENDIF}
CurWaveHdr:=Pointer(Msg.lParam); {Geleerter Puffer}
end;
ByteIndex:=0; {Schreibzeiger}
end;
end;
end;
procedure EndProcess1(OK:Boolean);
{Kontext: MMTASK.TSK, Funktion beendet Task}
var
os: TOfStruct;
FPos: LongInt absolute os;
begin
case Modus of
1: begin
if WaveInDev<>-2 then begin
WaveInReset(hWav); {Restliche (leere) Puffer "ausspucken"}
WaveInClose(hWav); {Gerät schließen}
end else _lclose(hWav);
end;
2: begin
if WaveOutDev<>-2 then begin
if OK then begin
if ByteIndex<>0 then begin
LongRec(CurWaveHdr^.dwBufferLength).Lo:=ByteIndex;
ProcessBlock;
end;
while WaveOutClose(hWav)<>0 {=WAVERR_StillPlaying}
do MMTaskBlock(Task);
end else begin
WaveOutReset(hWav); {im Abbruch-Fall}
end;
WaveOutClose(hWav);
end else begin
if OK then begin {WAV-Datei patchen}
FPos:=_llseek(hWav,0,1); {Momentanposition}
Dec(FPos,8);
_llseek(hWav,4,0);
_lwrite(hWav,PChar(@FPos),4);
Dec(FPos,$2C-8);
_llseek(hWav,$28,0);
_lwrite(hWav,PChar(@FPos),4);
end;
_lclose(hWav);
if not OK then OpenFile(WaveFileName,os,OF_Delete);
end;
end;
end{case};
FreeWaveBlock(Waves[0]);
if WaveInDev<>-2 then FreeWaveBlock(Waves[1]);
PostMessage(MainWnd,WM_EndProcess,Word(OK),0);
halt;
end;
function MakeWaveBlock(var M:THandle):PWaveHdr;
{benutzt globale Variablen hWav und Modus}
var
WH: PWaveHdr;
begin
M:=GlobalAlloc(GHND or GMEM_Share,sizeof(TWaveHdr)+WAVBLK);
WH:=GlobalLock(M);
WH^.lpData:=PChar(WH)+sizeof(TWaveHdr);
WH^.dwBufferLength:=WAVBLK;
if Modus=1
then WaveInPrepareHeader(hWav,WH,sizeof(TWaveHdr))
else WaveOutPrepareHeader(hWav,WH,sizeof(TWaveHdr));
MakeWaveBlock:=WH;
end;
procedure FreeWaveBlock(var M:THandle);
{benutzt globale Variablen hWav und Modus}
var
WH: PWaveHdr;
begin
GlobalUnlock(M); {der Block war die ganze Zeit gelockt!}
WH:=GlobalLock(M); {Pointer beschaffen}
if Modus=1
then WaveInUnprepareHeader(hWav,WH,sizeof(TWaveHdr))
else WaveOutUnprepareHeader(hWav,WH,sizeof(TWaveHdr));
GlobalUnlock(M);
M:=GlobalFree(M);
end;
function memcmpw(var p1, p2; vlen: Word):Boolean; assembler;
asm push ds
lds si,[p2]
les di,[p1]
mov cx,vlen
mov al,FALSE
cld
rep cmpsb {[SI]-[DI]}
pop ds
jnz @@e
inc al {TRUE}
@@e:
end;
procedure WaveInTask(CallProc:TCallProc);far;
{Kontext: MMTASK.TSK, Funktion beendet Task und kehrt nicht zurück}
var
I: Integer;
ThisWaveFileHdr: TWaveFileHdr;
begin
asm mov ax,seg @data; mov ds,ax; {$IFOPT D+} int 3 {$ENDIF} end;
if WaveInDev=-2 then begin
I:=mmsyserr_InvalHandle; {5}
hWav:=_lopen(WaveFileName,0);
if (_lread(hWav,PChar(@ThisWaveFileHdr),sizeof(TWaveFileHdr))
=sizeof(TWaveFileHdr))
then begin
I:=mmsyserr_NotSupported; {8}
if memcmpw(ThisWaveFileHdr.riff,WaveFileHdr.riff,2)
and memcmpw(ThisWaveFileHdr.wave,WaveFileHdr.wave,$10)
then I:=0
else _lclose(hWav);
end else _lclose(hWav);
end else begin
I:=Integer(WaveInOpen(@hWav,Word(WaveInDev),@WaveFileHdr.MyWav.wf,
MMGetCurrentTask,0,Callback_Task));
if I<>0 then begin
PostMessage(MainWnd,WM_ReportWaveError,I,0);
halt;
end;
MMTaskBlock(Task); {MM_WIM_Open entfernen}
WaveInAddbuffer(hWav,MakeWaveBlock(Waves[0]),sizeof(TWaveHdr));
CurWaveHdr:=MakeWaveBlock(Waves[1]);
ByteIndex:=$FFFF;
WaveInStart(hWav);
end;
CallProc;
EndProcess1(true);
end;
procedure WaveOutTask(CallProc:TCallProc);far;
{Kontext: MMTASK.TSK, Funktion beendet Task und kehrt nicht zurück}
var
I: Integer;
begin
asm mov ax,seg @data; mov ds,ax; {$IFOPT D+} int 3 {$ENDIF} end;
if WaveOutDev=-2 then begin
I:=mmsyserr_InvalHandle; {5}
hWav:=_lcreat(WaveFileName,0);
if hWav<>-1 then begin
if _lwrite(hWav,PChar(@WaveFileHdr),sizeof(WaveFileHdr))
=sizeof(WaveFileHdr)
then I:=0 {mmsyserr_NoError}
else _lclose(hWav);
end;
end else I:=Integer(WaveOutOpen(@hWav,Word(WaveOutDev),@WaveFileHdr.MyWav.wf,
MMGetCurrentTask,0,Callback_Task));
if I<>0 then begin
PostMessage(MainWnd,WM_ReportWaveError,I,0);
halt;
end;
if WaveOutDev<>-2 then begin
MMTaskBlock(Task); {MM_WOM_Open entfernen}
CurWaveHdr:=MakeWaveBlock(Waves[0]);
PostAppMessage(MMGetCurrentTask,MM_WOM_Done,hWav,
LongInt(MakeWaveBlock(Waves[1])));
end;
ByteIndex:=0;
CallProc;
EndProcess1(true);
end;
{-Laden-von-Kassette---------------------------------------------------------}
function ReadB:ShortInt;
{Kontext: MMTASK.TSK}
begin
with CurWaveHdr^ do begin
if ByteIndex>=LongRec(dwBytesRecorded).Lo
then ProcessBlock; {Nächsten Block einlesen}
end; {CurWaveHdr geändert, WITH beenden!!!}
with CurWaveHdr^ do begin
ReadB:=Integer(lpData[ByteIndex])-$80;
Inc(ByteIndex);
end;
end;
function ReadSwing1:Integer;
{Kontext: MMTASK.TSK}
var
W: Integer;
begin
W:=1;
if ReadB<0
then repeat Inc(W) until ReadB>0
else repeat Inc(W) until ReadB<0;
ReadSwing1:=W;
end;
function ReadSwing2: Integer;
{Kontext: MMTASK.TSK}
begin
ReadSwing2:=ReadSwing1+ReadSwing1;
end;
{*************************************}
{*** Formatabhängige Lese-Routinen ***}
{*************************************}
procedure ReadDataKCC; far;
{Kontext: MMTASK.TSK}
function KCBytein:Byte;
var
I,W:Integer;
B:Byte;
begin
for I:=0 to 7 do begin
w:=ReadSwing2;
B:=B SHR 1;
if w>16 then B:=B or $80;
end;
ReadSwing2;
KCBytein:=B;
end;
function ReadBlock(var BlkNr:Byte; var Buffer:TBlock):Boolean;
var
I,W:Integer;
B,Sum:Byte;
begin
ReadBlock:=false;
{Schritt 1: Vorton erkennen und aufsynchronisieren}
for I:=1 to 22 do begin
W:=ReadSwing2;
if (W<18) or (W>30) then begin
I:=0;
continue;
end;
end;
{Schritt 2: 1. Trennzeichen holen}
for I:=1 to 2 do begin
W:=ReadSwing1;
if (W<15) then begin
I:=0;
continue;
end;
end;
{Schritt 3: Bytes lesen}
BLKNr:=KCByteIn;
Sum:=0;
for I:=0 to 127 do begin
B:=KCByteIn;
Inc(Sum,b);
Buffer[I]:=b;
end;
If Sum=KCByteIn then ReadBlock:=true;
end;
var
ExpectBlock: Byte;
FirstBlock: Boolean;
BlkNr:Byte;
L:LongInt;
ok: Boolean;
S: TS31;
X,I,J: Integer; {Index für Blocknummer-OK und Blocknummer-Aktuell}
buf: TBlock;
SP2: PChar;
vsrec: record
bn: Integer;
ch: Char;
end;
w: Word;
begin
L:=$7FFFFFFF;
FirstBlock:=true;
for I:=300 downto 0 do begin
W:=ReadSwing2;
if (W<18) or (W>30) then I:=200;
end;
I:=wvsprintf(S,'LOAD ',I);
SetStat(S);
repeat
ok:=ReadBlock(BlkNr,buf);
vsrec.bn:=BlkNr;
if Firstblock then ExpectBlock:=BlkNr;
if OK then begin
if (BlkNr=ExpectBlock) or ((BlkNr=$FF) and not FirstBlock) then begin
vsrec.ch:='>';
J:=0;
AddData(PChar(@Buf),sizeof(buf));
if (BlkNr=$FF) and (ExpectBlock<>$FF) then exit;
if FirstBlock then begin
if buf[0]=$D3 then L:=buf[11]+buf[12]*256+14;
SP2:=PChar(@buf);
I:=GetFileName(S,SP2);
FirstBlock:=false;
end;
Inc(ExpectBlock);
end else begin
vsrec.ch:='*';
J:=4;
end;
end else begin
vsrec.ch:='?';
J:=4;
end;
wvsprintf(S+I+J,' %02X%c',vsrec);
SetStat(S);
until GetSize>L;
end;
procedure ReadDataMPMTurbo; far;
{Kontext: MMTASK.TSK}
function KCBytein:Byte;
var
I,W:Integer;
B:Byte;
begin
for I:=0 to 7 do begin
w:=ReadSwing1;
B:=B SHR 1;
if w>=10 then B:=B or $80;
end;
KCBytein:=B;
end;
function ReadBlock(var BlkNr:Byte; var Buffer:TBlock):Boolean;
label Try;
var
I,W:Integer;
B,Sum:Byte;
begin
ReadBlock:=false;
{Schritt 1: Vorton erkennen und aufsynchronisieren}
Try:
for I:=1 to 40 do begin
W:=ReadSwing1;
if W>=10 then begin
I:=0;
continue;
end;
end;
{Schritt 2: 1. Trennzeichen holen}
for I:=1 to 2 do begin
W:=ReadSwing1;
if W<10 then begin
if I=2 then Goto Try else I:=0;
continue;
end;
end;
{Schritt 3: Bytes lesen}
BLKNr:=KCByteIn;
Sum:=0;
for I:=0 to 127 do begin
B:=KCByteIn;
Inc(Sum,B);
Buffer[I]:=B;
end;
If Sum=KCByteIn then ReadBlock:=true;
end;
var
ExpectBlock: Byte;
FirstBlock: Boolean;
L:LongInt;
BlkNr:Byte;
ok: Boolean;
S: array[0..31] of Char;
I,J: Integer; {Index für Blocknummer-OK und Blocknummer-Aktuell}
buf: TBlock;
SP2: PChar;
vsrec: record
bn: Integer;
ch: Char;
end;
begin
L:=$7FFFFFFF;
FirstBlock:=true;
ExpectBlock:=1;
I:=wvsprintf(S,'TLOAD ',I);
SetStat(S);
repeat
ok:=ReadBlock(BlkNr,buf);
vsrec.bn:=BlkNr;
if OK then begin
if (BlkNr=ExpectBlock) or ((BlkNr=$FF) and not FirstBlock) then begin
vsrec.ch:='>';
J:=0;
AddData(PChar(@Buf),sizeof(buf));
if (BlkNr=$FF) and (ExpectBlock<>$FF) then exit;
if FirstBlock then begin
if buf[0]=$D3 then L:=buf[11]+buf[12]*256+14;
SP2:=PChar(@buf);
I:=GetFileName(S,SP2);
FirstBlock:=false;
end;
Inc(ExpectBlock);
end else begin
vsrec.ch:='*';
J:=4;
end;
end else begin
vsrec.ch:='?';
J:=4;
end;
wvsprintf(S+I+J,' %02X%c',vsrec);
SetStat(S);
until GetSize>L;
end;
procedure ReadDataHSTurbo; far;
{Kontext: MMTASK.TSK}
var
S: array[0..31] of Char;
I,W: integer;
Sum,B:Byte;
begin
ReadDataKCC;
SetStat(lstrcpy(S,'H#S TURBO'));
for I:=0 to 40 do begin
W:=ReadSwing1;
if W<12 then begin I:=0;continue;end;
end;
repeat
until ReadSwing1<12;
Sum:=0;
Repeat
for I:=0 to 7 do begin
w:=ReadSwing1;
B:=B SHL 1;
if w>20 then begin AddData(PChar(@Sum),1);exit;end;
if w>6 then B:=B or 1;
end;
inc(Sum,B);
AddData(PChar(@B),1);
until false
end;
procedure ReadDataZ1013; far;
{Kontext: MMTASK.TSK}
type
TBlk=array[0..15] of Word;
function Wordin:Word;
var
I:Integer;
W:Word;
begin
for I:=0 to 15 do begin
W:=W SHR 1;
if ReadSwing1>6 then W:=W or $8000 else ReadSwing1;
end;
Wordin:=W;
end;
function ReadBlock(var Buffer:TBlk):Boolean;
var
I:Integer;
W,Sum:Word;
begin
ReadBlock:=false;
{Schritt 2: 1. Trennzeichen holen}
for I:=1 to 2 do begin
W:=ReadSwing1;
if W>15 then begin
I:=0;
continue;
end;
end;
{Schritt 3: Bytes lesen}
Wordin;
Sum:=0;
for I:=0 to 15 do begin
W:=WordIn;
Inc(Sum,W);
Buffer[I]:=W;
end;
{If Sum=WordIn then} ReadBlock:=true;
end;
var
ok: Boolean;
S: array[0..31] of Char;
I,J: Integer; {Index für Blocknummer-OK und Blocknummer-Aktuell}
buf: TBlk;
begin
SetStat(lstrcpy(S,'Z1013LOAD '));
repeat
ok:=ReadBlock(buf);
if OK then begin
AddData(PChar(@Buf),sizeof(buf));
SetStat(lstrcpy(S,'>'));
end else begin
SetStat(lstrcpy(S,'?'));
end;
until Readswing2<100;
end;
procedure ReadDataBasicode; far;
{Kontext: MMTASK.TSK}
var
S: array[0..31] of Char;
I: Integer;
B,Sum:Byte;
function Bytein:Byte;
var
I,W:Integer;
B:Byte;
begin
for I:=1 to 2 do begin
W:=ReadSwing1;
if W<7 then begin
I:=0;
continue;
end;
end;
for I:=0 to 7 do begin
w:=ReadSwing2;
B:=B SHR 1;
if w<16 then begin B:=B or $80;ReadSwing2;end;
end;
Sum:=Sum xor B;
Bytein:=B xor $80;
end;
var
w: Word;
begin
SetStat(lstrcpy(S,'BASICODE '));
for I:=1 to 40 do begin
W:=ReadSwing1;
if W>=6 then begin
I:=0;
continue;
end;
end;
SetStat(lstrcat(S,'2400Hz'));
Sum:=$0;
If ByteIn=1 then ByteIn;
Repeat
B:=ByteIn;
If B=3 then begin
B:=Sum;
If ByteIn<>B then SetStat(lstrcpy(S,'Lesefehler erkannt!'));
ShortYield;
exit;
end;
AddData(PChar(@B),1);
if B=$0D then B:=0;
B:=B and $7F;
if B in [1..$1F,$7F] then B:=Byte('.');
S[I]:=Char(B);
if I<sizeof(S)-1 then Inc(I);
if B=0 then begin
SetStat(S);
I:=0;
end;
until false;
end;
{-Speichern-auf-Kassette-----------------------------------------------------}
procedure WriteB;
{Kontext: MMTASK.TSK}
begin
with CurWaveHdr^ do begin
lpData[ByteIndex]:=Char(Integer(Amp)+$80);
Inc(ByteIndex);
if ByteIndex>=LongRec(dwBufferLength).Lo
then begin
{$IFOPT D+} asm int 3 end; {$ENDIF}
ProcessBlock; {vollen Block schreiben}
end;
end;
end;
procedure WriteSwing1(Len:Integer);
{Kontext: MMTASK.TSK}
begin
if Len>=4 then asm {bei 4 bleibt die Amplitude auf 7/8}
mov al,[Amp]
neg al
push ax
mov [Amp],0
call WriteB
pop ax
push ax
sar al,1 {/2, Amp ist immer gerade!}
mov [Amp],al
call WriteB
pop ax
push ax
sar al,2 {/4}
add [Amp],al {3/4}
call WriteB
pop ax
push ax
sar al,3 {/8}
add [Amp],al {7/8}
call WriteB
pop ax
sub [Len],4
mov [Amp],al
end else asm
mov al,[Amp]
neg al
mov [Amp],al
end;
while Len<>0 do begin
WriteB; {Rest gerade (Gleichspannung)}
Dec(Len);
end;
end;
procedure WriteSwing2(Len:Integer);
{Kontext: MMTASK.TSK}
var
Len1:integer;
begin
Len1:=Len div 2;
WriteSwing1(Len1);
WriteSwing1(Len-Len1)
end;
procedure WriteDataKCC; far;
{Kontext: MMTASK.TSK}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
procedure WriteByte(B:Byte);
var
I,W:Integer;
begin
for I:=0 to 7 do begin
W:=12;
if B and 1 <>0 then W:=22;
WriteSwing2(W);
B:=B shr 1;
end;
WriteSwing2(38);
end;
procedure WriteBlock(BlkNr:Byte; const Buffer:TBlock; Vorton:Integer);
var
I,W:Integer;
B,Sum:Byte;
begin
for I:=1 to Vorton do WriteSwing2(22); {Vorton}
WriteSwing2(38); {Trennzeichen}
WriteByte(BlkNr);
Sum:=0;
for I:=0 to $7F do begin
Inc(Sum,Buffer[I]);
WriteByte(Buffer[I]);
end;
WriteByte(Sum);
end;
var
CurBlk: Byte;
S: array[0..31] of Char;
I: Integer;
buf: TBlock;
Erster_Block, Letzter_Block: Boolean;
begin
CurBlk:=1;
Erster_Block:=true;
Letzter_Block:=false;
repeat
I:=GetData(PChar(@buf),sizeof(buf));
if ((I<sizeof(buf)) or (GetSize=0))
and (not Erster_Block)
and (CurBlk<>$FF) then begin
Letzter_Block:=true;
CurBlk:=$FF;
end;
I:=$A0;
if Erster_Block then I:=$A00;
WriteBlock(CurBlk,buf,I);
I:=CurBlk;
Inc(CurBlk);
wvsprintf(S,'%02X<',I);
SetStat(S);
Erster_Block:=false;
until Letzter_Block;
end;
procedure WriteDataMPMTurbo; far;
{Kontext: MMTASK.TSK}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
procedure WriteByte(B:Byte);
var
I,W:Integer;
begin
for I:=0 to 7 do begin
W:=5;
if B and 1 <>0 then W:=9;
WriteSwing1(W);
B:=B shr 1;
end;
end;
procedure WriteBlock(BlkNr:Byte; const Buffer:TBlock; Vorton:Integer);
var
I,W:Integer;
B,Sum:Byte;
begin
for I:=1 to Vorton do WriteSwing2(9); {Vorton}
WriteSwing2(24); {Trennzeichen}
WriteByte(BlkNr);
Sum:=0;
for I:=0 to $7F do begin
Sum:=Sum xor Buffer[I];
WriteByte(Buffer[I]);
end;
WriteByte(Sum);
end;
var
CurBlk: Byte;
S: array[0..31] of Char;
I: Integer;
buf: TBlock;
Erster_Block, Letzter_Block: Boolean;
begin
CurBlk:=1;
Erster_Block:=true;
Letzter_Block:=false;
repeat
I:=GetData(PChar(@buf),sizeof(buf));
if ((I<sizeof(buf)) or (GetSize=0))
and (not Erster_Block)
and (CurBlk<>$FF) then begin
Letzter_Block:=true;
CurBlk:=$FF;
end;
I:=$70;
if Erster_Block then I:=$1000;
WriteBlock(CurBlk,buf,I);
I:=CurBlk;
Inc(CurBlk);
wvsprintf(S,'%02X<',I);
SetStat(S);
Erster_Block:=false;
until Letzter_Block;
end;
procedure WriteDataHSTurbo; far;
{Kontext: MMTASK.TSK}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
var
BTW: Longint;
B:Byte;
S: TS255;
begin
{Loader saven}
BTW:=BytestoWrite;BytestoWrite:=256;
WriteDataKCC;
BytestoWrite:=BTW;
{eigentliche Daten speichern}
SetStat(lstrcpy(S,'H#S TURBO'));
asm mov cx,512
@@l: push cx
push 30
call WriteSwing2
pop cx
loop @@l
end;
WriteSwing1(9);
while GetData(PChar(@B),1)<>0 do asm
mov cx,8
@@l: mov ax,5 {Null-Bit}
shl [B],1
jnc @@1
mov al,9 {Eins-Bit}
@@1: push cx
push ax
call WriteSwing1
pop cx
loop @@l
end;
end;
procedure WriteDataZ1013; far;
{Kontext: MMTASK.TSK}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
type
TBlk=array[0..15] of Word;
var
S: array[0..31] of Char;
I:integer;
buf:TBlk;
procedure WriteWord(W:Word);
var
I:Integer;
begin
wvsprintf(S,'%04X',W);Setstat(s);
for I:=0 to 15 do begin
if W and 1 <>0 then WriteSwing1(9) else WriteSwing2(9);
W:=W shr 1;
end;
end;
procedure WriteBlock(const Buffer:TBlk; Vorton:Integer);
var
I:Integer;
Sum:Word;
begin
for I:=1 to Vorton do WriteSwing1(17); {Vorton}
WriteSwing2(16); {Trennzeichen}
WriteWord(0);
Sum:=0;
for I:=0 to 15 do begin
inc(Sum,Buffer[I]);
WriteWord(Buffer[I]);
end;
WriteWord(Sum);
end;
begin
I:=2000;
SetStat(lstrcpy(S,'Z1013 Save'));
While GetSize>0 do begin
GetData(PChar(@buf),sizeof(buf));
WriteBlock(buf,I);
I:=14;
end;
end;
procedure WriteDataBasicode; far;
{Kontext: MMTASK.TSK}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
var
S: array[0..31] of Char;
I: Integer;
B,Sum:Byte;
procedure WriteByte(B:Byte);
var
I,W:Integer;
begin
Sum:=Sum xor B;
WriteSwing2(18);
for I:=0 to 7 do begin
if B and 1 =0 then WriteSwing2(18)
else begin WriteSwing2(9);WriteSwing2(9);end;
B:=B shr 1;
end;
WriteSwing2(9);WriteSwing2(9);
end;
begin
Sum:=0;
for I:=1 to 9000 do WriteSwing2(9);
WriteByte(2);
I:=0;
while GetData(PChar(@B),1)<>0 do begin
WriteByte(B);
if B=$0D then B:=0;
B:=B and $7F;
if B in [1..$1F,$7F] then B:=Byte('.');
S[I]:=Char(B);
if I<sizeof(S)-1 then Inc(I);
if B=0 then begin
SetStat(S);
I:=0;
end;
end;
WriteByte(3);
WriteByte(Sum xor $80);
for I:=1 to 3500 do WriteSwing2(9);
end;
{-Dialogfunktionen-----------------------------------------------------------}
const
ID_OfnWriteProt=1040;
function OFNHook(Wnd:HWnd; Msg,wParam:Word; lParam:Longint):Word; export;
{trägt lediglich 'mit Vorblock' ein;
sollt bei SAVE aber erkennen, ob es eine BASIC-Datei ist und das
OFN_ReadOnly-Flag entsprechend setzen! }
var
S: TS31;
begin
OFNHook:=0;
case Msg of
WM_InitDialog: begin
LoadString(Seg(HInstance),108,S,sizeof(S));
SetDlgItemText(Wnd,ID_OfnWriteProt,S);
end;
end{case Msg};
end;
function lstrcmpin2(LongS,ShortS:PChar):Integer;
{Ist ShortS der Anfang von LongS?}
var
c: Char;
SP: PChar;
begin
SP:=LongS+lstrlen(ShortS);
c:=SP^;
SP^:=#0;
lstrcmpin2:=lstrcmpi(LongS,ShortS);
SP^:=c;
end;
var
SFile: TS255;
SFilter: TS255;
SExt: TS31;
const
hm: Word=WM_User+100; {HelpMessageString-Nachricht}
const
Ofn: TOpenFileName=(
lStructSize: sizeof(TOpenFileName);
hWndOwner: 0;
hInstance: Seg(HInstance);
lpstrFilter: SFilter;
lpstrCustomFilter: SExt;
nMaxCustFilter: sizeof(SExt);
nFilterIndex: 0;
lpstrFile: SFile;
nMaxFile: sizeof(SFile);
lpstrFileTitle: nil;
nMaxFileTitle: 0;
lpstrInitialDir: nil;
lpstrTitle: nil;
Flags: OFN_LongNames or OFN_ShowHelp
or OFN_EnableHook or OFN_OverwritePrompt;
nFileOffset: 0;
nFileExtension: 0;
lpstrDefExt: nil;
lCustData: 0;
lpfnHook: OFNHook;
lpTemplateName: nil);
procedure PrepareOFN;
var
SP1,SP2:PChar;
I: Integer;
begin
hm:=RegisterWindowMessage(HelpMsgString);
Ofn.hWndOwner:=MainWnd;
LoadString(Seg(HInstance),107,SFilter,sizeof(SFilter));
if Integer(Ofn.nFilterIndex)<>0 then begin
SP1:=SFilter; {Mißbrauch!}
for I:=Integer(Ofn.nFilterIndex)*2 downto 2 {min. 1x}
do Inc(SP1,lstrlen(SP1)+1);
{Bug der COMMDLG.DLL bereinigen}
if lstrcmpin2(SP1,SExt+1)<>0 then begin
SP2:=SP1+lstrlen(SP1); {String-Ende}
memmove(SP1+lstrlen(SExt+1),SP2,SFilter+sizeof(SFilter)-SP2);
lstrcpy(SP1,SExt+1); {User-Extension einfügen}
end;
end;
SFile[0]:=#0;
end;
procedure PutFileName(pBuf:PChar); assembler;
{Dateiname vom globalen String SFile einbauen;
dabei Name und Erweiterung mit Leerzeichen auffüllen;
weitere Voraussetzungen sind gültige Einträge ofn.nFileOffset,
ofn.nFileExtension und ofn.nFilterIndex.
Bei Erweiterungen mit 3 gleichen Buchstaben UND ofn.nFilterIndex=3
(BASIC-Programm) wird diese an den Anfang gezogen und 80h addiert,
als Extrawurst für BASIC-Programme und ~Daten}
asm cld
les di,[pBuf]
xor dx,dx {Merk-Register}
mov al,byte ptr [ofn.nFilterIndex]
cmp al,3 {BASIC ausgewählt?}
jne @@1 {nein, Extension egal}
mov cx,[ofn.nFileExtension]
jcxz @@1 {keine Endung!}
mov si,offset SFile
add si,cx
lodsb {1. Zeichen der Endung}
cmp [si],al {Vgl. mit 2. Zeichen}
jnz @@1
cmp [si+1],al {Vgl. mit 3. Zeichen}
jnz @@1
and al,not 20h {Großbuchstabe}
cmp al,'S'
jc @@1 {kein .SSS .. .ZZZ}
cmp al,'Z'
ja @@1
or al,80h {zuerst Extension+80h}
stosb
stosb
stosb
inc dl {Kennungs-Bit: Extension geschrieben}
@@1: mov si,offset SFile
add si,[ofn.nFileOffset]
mov cx,8
@@l1: lodsb
or al,al {Ende extensionsloser Dateiname}
jz @@2
cmp al,'.' {Ende Dateiname (Namensbestandteil)}
je @@2 {eigentlich ist der LETZTE Punkt maßgebend!}
stosb
loop @@l1
@@2: mov al,' '
rep stosb {Rest mit Leerzeichen auffüllen (CX=0 = nix)}
or dl,dl {Endung vorgezogen?}
jnz @@3
inc dl {keine Rekursion!}
mov cx,[ofn.nFileExtension]
jcxz @@2 {Keine Extension?}
mov si,offset SFile
add si,cx
mov cx,3 {noch 3 Bytes löschen!}
jmp @@l1 {Extension <blank-padded> anhängen}
@@3: end;
function GetFileName(S,buf:PChar):integer;assembler;
{Dateiname von Pufferzeiger buf (hier: 11 Bytes, mit Leerzeichen aufgefüllt)
nach S (als ASCIIZ 8.3) extrahieren}
asm cld
push ds
les di,[S]
lds si,[Buf]
xor dx,dx
xor bx,bx
mov cx,8 {8 Zeichen}
lodsb {1. Zeichen}
test al,al {Endung am Anfang?}
jns @@1
mov dx,11 {Kennung}
add si,2 {mit dem 4. Zeichen loslegen}
@@l1: lodsb
@@1: and al,7Fh
cmp al,' ' {Leer- und Steuerzeichen?}
jbe @@2 {einfach auslassen}
stosb {Alle anderen (auch verbotene W31) in Puffer}
inc bx
@@2: loop @@l1
mov al,'.'
stosb {jetzt kommt die Extension!}
inc bx
sub si,dx {Korrektur, wenn Extension vorn war!}
mov cx,3
@@l2: lodsb
and al,7Fh
cmp al,' '
jbe @@3
stosb
inc bx
@@3: loop @@l2
xor al,al
stosb {Terminierende Null}
@@e: pop ds
mov ax,bx
end;
function LoadFile:Boolean;
label exi, exi2;
const
ExtraHeader: array[1..5] of Byte=(0,$80,11,0,$60);
CutHeader: array[1..5] of Byte=($80,0,2,0,$20);
var
{ BytesWritten:Longint;}
f,Add,I: Integer;
Sum: Byte;
pBuf: PChar;
hLdr: THandle;
C: Char;
Autostart: Boolean;
aadr,eadr,sadr: Word;
buf: TBlock;
begin
LoadFile:=false;
PrepareOfn;
with ofn do begin
Flags:=Flags or OFN_FileMustExist;
if not GetOpenFileName(ofn) then exit;
f:=_lopen(SFile,0);
if f=-1 then exit;
BytesToWrite:=_llseek(f,0,2); {Dateilänge}
_llseek(f,0,0); {Zeiger zurück}
Add:=ExtraHeader[Word(nFilterIndex)];
if coding=2 then begin
if Byte(nFilterIndex)=4 then exit; {Unsinn mit BASICODE}
Add:=CutHeader[Word(nFilterIndex)];
hLdr:=LoadResource(Seg(HInstance), {Turboloadervorblock}
FindResource(Seg(HInstance),MakeIntResource(102),RT_RCData));
if hLdr=0 then RunError(220); {Böser Fehler!}
Dec(BytesToWrite,Add);
hBuffer:=GlobalAlloc(GMEM_MoveAble or GMEM_Share,BytesToWrite+$100);
pBuf:=GlobalLock(hBuffer);
MemMove(pBuf,LockResource(hLdr),$100);
UnlockResource(hLdr);
FreeResource(hLdr);
Autostart:=false;
if (Add<>0)
and (_lread(f,PChar(@buf),Add)<>Add) then goto exi; {Datei zu kurz}
case Byte(nFilterIndex) of
1: begin {.KCC}
aadr:=PWord(@buf[$11])^;
eadr:=PWord(@buf[$13])^;
if buf[$10]>=3 then begin
Autostart:=true;
sadr:=PWord(@buf[$15])^;
end;
end;
2: begin {Speicherabzug: hier fest ab 200h}
aadr:=$200; {CP/M-Freaks würden hier 100h setzen}
eadr:=BytesToWrite+aadr;
end;
3: begin {BASIC-Programm}
aadr:=$401; {wird eigentlich nicht benutzt}
eadr:=PWord(@buf[0])^+aadr;
end;
5: begin {.Z80 - noch nicht benutzt}
aadr:=PWord(@buf[0])^;
eadr:=PWord(@buf[2])^;
if Char(buf[$0C])='C' then begin
Autostart:=true;
sadr:=PWord(@buf[4])^;
end;
end;
end{case};
if Byte(nFilterIndex)=3 then begin {Extrawurst für BASIC}
MemMove(pbuf+$80,pbuf+$70,$0A);
PWord(@pbuf[$81])^:=eadr;
end else begin
PWord(pbuf+$81)^:=aadr;
PWord(@pbuf[$84])^:=eadr;
end;
PWord(pbuf+$A8)^:=eadr-aadr;
if Autostart then begin
pbuf[$E0]:=Char($C3); {JMP nn}
PWord(pbuf+$E1)^:=sadr;
end;
if _hread(f,pbuf+$100,BytesToWrite)<>BytesToWrite then goto exi;
Inc(BytesToWrite,$100); {nun: alle Bytes}
sum:=0; {Rest laden - Datei zu kurz?}
for i:=$100 to BytesToWrite do inc(sum,byte(pBuf[I]));
pBuf[$D8]:=char(Sum); {Prüfsumme einsetzen}
GlobalUnlock(hBuffer);
end else begin
hBuffer:=GlobalAlloc(GMEM_MoveAble or GMEM_Share or GMEM_ZeroInit,
BytesToWrite+Add);
pBuf:=GlobalLock(hBuffer);
if _hread(f,pBuf+Add,BytesToWrite)<>BytesToWrite then goto exi;
Inc(BytesToWrite,Add);
end;
if (Add<>0)
or (nFilterIndex=1) and (pbuf[0]=#0)
then PutFileName(pBuf);
if (Byte(nFilterIndex)=2)
and (coding<>2) then begin
PByte(pBuf+$10)^:=2; {ARGN; ARG1 bleibt 0}
PWord(pBuf+$13)^:=LongRec(BytesToWrite).Lo; {ARG2=EAdr+1}
end;
if _lclose(f)<>0 then goto exi2;
GlobalUnlock(hBuffer);
LoadFile:=true;
exit;
exi:
_lclose(f);
exi2:
GlobalUnlock(hBuffer);
hBuffer:=GlobalFree(hBuffer);
MBox1(MainWnd,105,SFile);
end{with};
end;
function SaveFile:Boolean;
var
BytesWritten: Longint;
f,Add: Integer; {Add= 0 oder 11}
pBuf: PChar;
C: Char;
begin
SaveFile:=false;
Add:=0;
PrepareOfn;
{für Turbolader h#s und Z1013 Dateinamensinklusion weglassen}
pBuf:=GlobalLock(hBuffer);
GetFileName(SFile,pBuf);
with ofn do begin
if pBuf[0]<char($80) then Flags:=Flags or OFN_ReadOnly
else Flags:=Flags and not OFN_ReadOnly;
Flags:=Flags or OFN_PathMustExist;
if not GetSaveFileName(ofn) then exit;
if coding=2 then begin
if pBuf[$D8]<>pBuf[BufPtr-1] then
if MBox1(MainWnd,111,SFile)=IDCANCEL then exit;
if pBuf[$80]=char($21) then begin {Maschinenprg.}
Dec(BufPtr,$81);
asm
les di,[pBuf]
mov si,di
add di,11
xor ax,ax
mov cx,6
rep stosb
add si,81h
seges lodsw
stosw
inc si
seges lodsw
stosw
add si,5Ah
sub di,5
push si
seges lodsb
cmp al,0C3h
jnz @@1
mov al,3
stosb
add di,4
seges lodsw
jmp @@2
@@1: mov al,2
stosb
add di,4
xor ax,ax
@@2: stosw
mov cx,69h
xor ax,ax
rep stosb
pop si
add si,20h
mov cx,word[BufPtr]
@@3: seges lodsb
stosb
loop @@3
end;
end else begin {BASIC Prg.}
asm
les di,[pBuf]
mov si,di
add si,81h
seges lodsw
dec ax
stosw
add si,7Eh
mov cx,word[BufPtr]
@@1: seges lodsb
stosb
loop @@1
end;
Dec(BufPtr,$100);
end;
end else begin
if Flags and OFN_ReadOnly <>0 then
if pBuf[0]>char($7F) then begin
Add:=11;
if pBuf[0]=char($D3) then BufPtr:=byte(pBuf[11])+byte(pBuf[12])*256+14;
end else Add:=$80;
end;
f:=_lcreat(SFile,0);
if f=-1 then begin
GlobalUnlock(hBuffer);
exit;
end;
Dec(BufPtr,Add);
BytesWritten:=_hwrite(f,pBuf+Add,BufPtr);
GlobalUnlock(hBuffer);
if (_lclose(f)<>0) or (BytesWritten<>BufPtr) then begin
MBox1(MainWnd,106,SFile);
exit;
end;
SaveFile:=true;
end;
end;
function GetInt(var S: PChar; Def:Integer):Integer;
var
SP: PChar;
I,J: Integer;
begin
GetInt:=Def;
if S=nil then exit;
SP:=lStrChr(S,' ');
if SP<>nil then begin
SP^:=#0;
end;
Val(S,I,J);
if SP<>nil then S:=SP+1;
if J=0 then GetInt:=I;
end;
procedure HandleMMError(Code:Integer);
var
S: array[0..255] of Char;
begin
case Code of
MMSysErr_Allocated: MBox1(MainWnd,102,nil);
WAVERR_Sync: MBox1(MainWnd,101,nil);
else begin
WaveInGetErrorText(Code,S,sizeof(S));
MBox1(MainWnd,103,S)
end;
end;
end;
procedure SetModus(NewModus:Integer);
begin
if Modus<>NewModus then begin
Modus:=NewModus;
EnableWindow(GetDlgItem(MainWnd,1),Modus=0);
EnableWindow(GetDlgItem(MainWnd,22),Modus=0);
ShowWindow(GetDlgItem(MainWnd,2),Integer(Modus<>0));
ShowWindow(GetDlgItem(MainWnd,3),Integer(Modus=0));
end;
if GetFocus=0 then SetFocus(GetDlgItem(MainWnd,12));
end;
function GetLibProc(Entry:PChar):TFarProc;
var
P: TFarProc;
LibName: TS31;
begin
GetLibProc:=nil;
SendDlgItemMsgP(MainWnd,12,CB_GetLbText,coding,@LibName);
LibInst:=LoadLibrary(LibName);
if LibInst<32 then begin
MBox1(MainWnd,114,LibName);
exit;
end;
P:=GetProcAddress(LibInst,Entry);
if P=nil then begin
MBox1(MainWnd,115,Entry);
FreeLibrary(LibInst);
LibInst:=0;
exit;
end;
GetLibProc:=P;
end;
procedure DoEndProcess(OK:Boolean);
begin
if OK and (Modus=1) then SaveFile;
if hBuffer<>0 then hBuffer:=GlobalFree(hBuffer);
if LibInst>=32 then FreeLibrary(LibInst);
SetModus(0);
end;
procedure Change(Wnd:HWnd;ID:Word;Min,Max:Integer;B:Boolean);
var
I,C: Integer;
OK: Bool;
begin
I:=GetDlgItemInt(Wnd,ID,@OK,true);
if not OK then exit;
If B Then begin If (I<Max) Then Inc(I) end
Else If (I>Min) Then Dec(I);
SetDlgItemInt(Wnd,ID,I,true);
end;
function LoadProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):Bool; export;
var
lPar: LongRec absolute lParam;
WH: PWaveHdr absolute lParam;
S: array[0..255] of Char;
WaveOutCaps: TWaveOutCaps;
WaveInCaps: TWaveInCaps absolute WaveOutCaps; {ist kürzer!}
LF: TLogFont absolute S;
SP: PChar;
Proc: TFarProc absolute SP;
W: Word;
I,J,K: Integer;
B: Bool absolute K;
vsrec: array[0..4] of Integer;
begin
LoadProc:=false;
case Msg of
WM_InitDialog: begin
MainWnd:=Wnd; {Globale Variable setzen}
W:=GetSystemMenu(Wnd,false);
DeleteMenu(W,SC_Zoom,MF_ByCommand);
DeleteMenu(W,SC_Size,MF_ByCommand);
ShowWindow(Wnd,CmdShow); {Icon? - Sofort wirksam machen!}
Back:=CreateSolidBrush($FF0000); {Blau}
PostMessage(Wnd,WM_ContinueInit,0,0);
end;
WM_ContinueInit: begin
UpdateWindow(Wnd); {würde in InitDialog nichts bringen !!}
SP:=nil;
if RegGetRoot(RegPath,S,sizeof(S)) then begin
SP:=S;
Installed:=true;
end;
Retries:=GetInt(SP,4);
Coding:=GetInt(SP,0);
WaveVol:=GetInt(SP,4);
WaveInDev:=GetInt(SP,0);
WaveOutDev:=GetInt(SP,0);
SetDlgItemInt(Wnd,11,Retries,true);
LoadString(Seg(HInstance),104,S,sizeof(S));
SP:=S;
W:=GetDlgItem(Wnd,12);
while SP^<>#0 do begin
SendMessageP(W,CB_AddString,0,SP);
Inc(SP,lstrlen(SP)+1);
end;
SendMessageP(W,CB_Dir,0,PChar(UserDllFilter));
SendMessage(W,CB_SetCurSel,Coding,0);
SetDlgItemInt(Wnd,13,WaveVol,true);
W:=GetDlgItem(Wnd,14); {Handle Kombobox WaveIN}
LoadString(Seg(HInstance),112,S,sizeof(S));
K:=SendMessageP(W,CB_AddString,0,@S);
SendMessage(W,CB_SetItemData,K,-2);
I:=WaveInGetNumDevs;
for J:=-1 to I-1 do begin {mit Wave_Mapper beginnen}
if (WaveInGetDevCaps(Word(J),@WaveInCaps,sizeof(WaveInCaps))=0)
and (WaveInCaps.dwFormats and WAVE_Format_2M08 <>0) then begin
K:=SendMessageP(W,CB_AddString,0,@WaveInCaps.szPName);
SendMessage(W,CB_SetItemData,K,J);
if J=WaveInDev then SendMessage(W,CB_SetCurSel,K,0);
end;
end;
W:=GetDlgItem(Wnd,15); {Handle Kombobox WaveOUT}
K:=SendMessageP(W,CB_AddString,0,@S);
SendMessage(W,CB_SetItemData,K,-2);
I:=WaveOutGetNumDevs;
for J:=-1 to I-1 do begin {mit Wave_Mapper beginnen}
if (WaveOutGetDevCaps(Word(J),@WaveOutCaps,sizeof(WaveOutCaps))=0)
and (WaveOutCaps.dwFormats and WAVE_Format_1M08 <>0)
and (WaveOutCaps.dwSupport and WAVECAPS_Sync =0) then begin
K:=SendMessageP(W,CB_AddString,0,@WaveOutCaps.szPName);
SendMessage(W,CB_SetItemData,K,J);
if J=WaveOutDev then SendMessage(W,CB_SetCurSel,K,0);
end;
end;
GetObject(SendMessage(Wnd,WM_GetFont,0,0),sizeof(lf),@lf);
lstrcpy(lf.lfFaceName,'Courier');
SendDlgItemMessage(Wnd,10,WM_SetFont,CreateFontIndirect(lf),0);
end;
WM_CtlColor: if (lPar.Hi=CtlColor_Static)
and (GetWindowWord(lPar.Lo,GWW_ID)=10) then begin
LoadProc:=Bool(Back);
SetTextColor(wParam,$FFFFFF);
SetBkMode(wParam,Transparent);
end;
WM_EndProcess: DoEndProcess(Boolean(wParam));
WM_SetStatus: SetDlgItemText(Wnd,10,PChar(lParam));
WM_ReportWaveError: begin {in MMTASK Fehler bei WaveInOpen()}
HandleMMError(wParam);
hBuffer:=GlobalFree(hBuffer);
SetModus(0);
end;
WM_VScroll: begin
lPar.Lo:=GetDlgCtrlID(GetWindow(lPar.Hi,GW_HWndPrev));
if (wParam=SB_LineUp) or (wParam=SB_LineDown) then begin
Change(Wnd,lPar.Lo,0,7,wParam=SB_LineUp);
end;
end;
WM_QueryEndSession: if (Modus<>0)
and (MBox1(Wnd,113,nil)<>IDYes) then LoadProc:=true;
WM_EndSession: if Bool(wParam) and Installed
then SendMessage(Wnd,WM_Command,23,0);
WM_Close: begin
if (Modus<>0) then begin
if MBox1(Wnd,113,nil)<>IDYes then begin
LoadProc:=true; {Nicht beenden!}
exit;
end;
SendMessage(Wnd,WM_Command,IDCancel,0);
end;
DeleteObject(Back);
if Installed then SendMessage(Wnd,WM_Command,23,0);
EndDialog(Wnd,1);
end;
WM_Command: case wParam of
{Änderungen an den Eingabe-Elementen erfassen}
11: if lPar.Hi=EN_Change then begin
I:=GetDlgItemInt(Wnd,wParam,@B,true);
if B and (I>=0) and (I<=255) then Retries:=I;
end;
12: if lPar.Hi=CBN_SelChange then begin
I:=SendMessage(lPar.Lo,CB_GetCurSel,0,0);
if I>=0 then Coding:=I{SendMessage(lPar.Lo,CB_GetItemData,I,0)};
end;
13: if lPar.Hi=EN_Change then begin
I:=GetDlgItemInt(Wnd,wParam,@B,true);
if B and (I>=0) and (I<=7) then begin
WaveVol:=I;
I:=sqr(WaveVol)*2;
if Amp>=0 then Amp:=I else Amp:=-I;
end;
end;
14: if lPar.Hi=CBN_SelChange then begin
I:=SendMessage(lPar.Lo,CB_GetCurSel,0,0);
if I>=0 then WaveInDev:=SendMessage(lPar.Lo,CB_GetItemData,I,0);
end;
15: if lPar.Hi=CBN_SelChange then begin
I:=SendMessage(lPar.Lo,CB_GetCurSel,0,0);
if I>=0 then WaveOutDev:=SendMessage(lPar.Lo,CB_GetItemData,I,0);
end;
{Tastendrücke}
3: SendMessage(Wnd,WM_Close,0,0); {Programmende}
IDCancel: begin {Abbruch}
LoadString(Seg(HInstance),110,S,sizeof(S));
SetDlgItemText(MainWnd,10,S);
if Modus<>0 then begin
if IsTask(Task) then PostAppMessage(Task,WM_Quit,0,0)
else SetModus(0);
end;
end;
1: if Modus=0 then begin {Datei einlesen}
case coding of
0: Proc:=@ReadDataKCC;
1: Proc:=@ReadDataMPMTurbo;
2: Proc:=@ReadDataHSTurbo;
3: Proc:=@ReadDataZ1013;
4: Proc:=@ReadDataBasicode;
else begin
Proc:=GetLibProc('LOAD'); {Benutzer-definiert...}
if Proc=nil then exit;
end;
end;
hBuffer:=GlobalAlloc(GMEM_MoveAble or GMEM_Share,$8000);
BufPtr:=0;
SetModus(1);
MMTaskCreate(@WaveInTask,Task,LongInt(Proc));
end;
22: if Modus=0 then begin {Datei ausgeben}
if not LoadFile then exit;
case coding of
0: Proc:=@WriteDataKCC;
1: Proc:=@WriteDataMPMTurbo;
2: Proc:=@WriteDataHSTurbo;
3: Proc:=@WriteDataZ1013;
4: Proc:=@WriteDataBasicode;
else begin
Proc:=GetLibProc('SAVE');
if Proc=nil then exit;
end;
end;
BufPtr:=0;
Amp:=sqr(WaveVol)*2;
SetModus(2);
MMTaskCreate(@WaveOutTask,Task,LongInt(Proc));
end;
23: begin
Installed:=true;
wvsprintf(S,'%d %d %d %d %d',Retries);
RegSetRoot(RegPath,S);
end;
9: WinHelp(Wnd,HelpFileName,HELP_Contents,0);
end{WM_Command};
else if Msg=hm then WinHelp(Wnd,HelpFileName,HELP_Context,1);
end;
end;
const
wc:TWndClass=(
style: CS_VRedraw or CS_HRedraw;
lpfnWndProc: @DefDlgProc;
cbClsExtra: 0;
cbWndExtra: DlgWindowExtra;
hInstance: Seg(HInstance);
hIcon: 0;
hCursor: 0;
hbrBackground:Color_Background+1;
lpszMenuName: nil;
lpszClassName:'KCLOAD');
{FAR+EXPORT-Wrapper-Routinen (interne Routinen arbeiten mit NEAR)}
function ReadSwing:Integer; export;
begin ReadSwing:=ReadSwing1; end;
procedure WriteSwing(Len:Integer); export;
begin WriteSwing1(Len); end;
procedure EndProcess(OK:Boolean); export;
begin EndProcess1(OK); end;
procedure SetStatus(S:PChar); export;
begin SetStat(S); end;
function GetSizeData:Longint; export;
begin GetSizeData:=GetSize; end;
function GetDataBlock(P:PChar; Size:Integer):Integer; export;
begin GetDataBlock:=GetData(P,Size); end;
procedure AddDataBlock(P:PChar; Size:Integer); export;
begin AddData(P,Size); end;
exports
ReadSwing index 2, {Flußwechsel lesen}
WriteSwing index 3, {Flußwechsel schreiben}
EndProcess index 4, {Vorzeitig abbrechen}
SetStatus index 5, {Statuszeile setzen}
GetSizeData index 6, {restliche Bytes ermitteln}
GetDataBlock index 7, {Nächsten Datenblock aus Puffer lesen}
AddDataBlock index 8; {Neuen Datenblock in Puffer anhängen}
begin
LoadString(Seg(HInstance),100,AppName,sizeof(AppName));
WUtils.StdMBoxTitle:=AppName; {MessageBox-Titel in Unit setzen}
if HPrevInst<>0 then begin {Nicht doppelt starten!}
MainWnd:=FindWindow('KCLOAD',nil);
SetActiveWindow(MainWnd);
ShowWindow(MainWnd,SW_Restore);
halt(221);
end;
wc.hIcon:=LoadIcon(Seg(HInstance),MakeIntResource(100));
wc.hCursor:=LoadCursor(0,IDC_Arrow);
RegisterClass(wc);
DialogBox(Seg(HInstance),MakeIntResource(100),0,@LoadProc);
end.
Test für das MFM-Verfahren am KC
var
I,J,W:Integer;
B:Byte;
begin
{Loader saven, Adressen und CTC poken}
for I:=0 to 2000 do WriteSwing1(6);
WriteSwing1(12);WriteSwing1(12);
J:=0;I:=7;
while GetData(PChar(@B),1)<>0 do begin
for I:=0 to 7 do begin
case J of
0: if B and 1 =0 then begin WriteSwing1(6);end
else begin WriteSwing1(19);J:=1;end;
1: if B and 1 =0 then begin J:=2;end
else begin WriteSwing1(6);end;
2: if B and 1 =0 then begin WriteSwing1(12);J:=0;end
else begin WriteSwing1(19);J:=1;end;
end;
B:=B shr 1;
end;
end;
end;
Detected encoding: OEM (CP437) | 1
|
|