program LOAD;
{$D KC-Load 0.40 (03/98)}
{$C MOVEABLE PRELOAD PERMANENT}
{$R LOAD.RES}
uses
WinTypes, WinProcs, Win31, MMSystem, Strings, CommDlg{, ShellApi},
WUtils;
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)}
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;
BytesRead: LongInt;
BytesToWrite: LongInt absolute BytesRead; {Abwärtszähler!?}
BytesWritten: LongInt;
AppName: array[0..31] of Char;
Disp: array[0..20] of Char;
CurWaveHdr: PWaveHdr; {ZeigerZeiger auf momentan zu prozessierende Daten}
Task: THandle;
const
fsmpl= 11025;
f0600= 12;
f1200= 6;
f2400= 3;
{ f1400= 10;
f1000= 12;
f2000= 6;}
WAVBLK=$2000;
MyWav: TPCMWaveFormat=(
wf:(
wFormatTag: WAVE_Format_PCM;
nChannels: 1;
nSamplesPerSec: fsmpl;
nAvgBytesPerSec: fsmpl;
nBlockAlign: 1);
wBitsPerSample: 8);
WM_ContinueInit=WM_User+10;
WM_EndProcess=WM_User+11;
WM_SetStatus=WM_User+12;
type
TBlock=array[0..127] of Byte;
DecENc=record
X:Word; {Merker für Saveteil}
T:Byte; {Zeitpunkt in der Schwingung}
F:Byte; {Frequenz: Länge der Schwingung}
A:ShortInt; {Amplitude -128..+127}
W:Integer; {Anzahl des HalbWellen}
M:Integer; {Merker}
N:Byte; {Blocknummer}
C:Byte; {CRC-Prüfsumme}
D:Byte; {Datenbyte-Nr.}
Z:Byte; {Bit-Zähler}
B:Byte; {Ausgabebyte}
end;
var
MainWnd: HWnd; {Global ist besser im Zugriff!}
hBuffer: THandle; {Speicherabbild der Datei, Wachstum in 16K-Schritten?}
DEN: DecEnC;
I,W:Integer;
S: array[0..20]of Char;
FWAV,FSAV: String;
FW: File;
FS: File of TBlock;
ok: Boolean;
ByteIndex: Word;
Amp: ShortInt;
procedure EndProcess1(OK:Boolean); forward;
function SaveFile:Boolean; forward;
procedure FreeWaveBlock(var M:THandle); forward;
procedure EnableButtons; forward;
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
Msg: TMsg;
begin
if (Modus=2) and OK then begin
if ByteIndex<>0 then begin
LongRec(CurWaveHdr^.dwBufferLength).Lo:=ByteIndex;
ProcessBlock;
end;
while WaveOutClose(hWav)<>0 {=WAVERR_StillPlaying}
do GetMessage(Msg,0,0,0);
end;
PostMessage(MainWnd,WM_EndProcess,Word(OK),0);
halt;
end;
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;
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
asm int 3 end;
ProcessBlock; {vollen Block schreiben}
end;
end;
end;
procedure WriteSwing1(Len:Integer);
{Kontext: MMTASK.TSK}
begin
Amp:=-Amp;
for Len:=Len downto 1 do WriteB;
end;
procedure WriteSwing2(Len:Integer);
{Kontext: MMTASK.TSK}
begin
WriteSwing1(Len);
WriteSwing1(Len);
end;
function ReadSwing2: Integer;
begin
ReadSwing2:=ReadSwing1+ReadSwing1;
end;
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>8 then B:=B or $80;
end;
ReadSwing2;
KCBytein:=B;
end;
function ReadBlock(var BlkNr:Byte; var Buffer:TBlock):Boolean;
{Kontext: MMTASK.TSK}
Label Try;
var
I,W:Integer;
B,Sum:Byte;
begin
ReadBlock:=false;
{Schritt 1: Vorton erkennen und aufsynchronisieren}
Try:
for I:=1 to 22 do begin
W:=ReadSwing2;
if (W<8) or (W>15) then begin
I:=1;
continue;
end;
end;
{Schritt 2: 1. Trennzeichen holen}
for I:=1 to 2 do begin
W:=ReadSwing1;
if (W<7) then begin
I:=0;
continue;
end;
if (W>13) then goto Try;
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;
procedure ReadDataKCC; far;
{Kontext: MMTASK.TSK, Routine beendet die Task}
var
ExpectBlock: Byte;
BlkNr:Byte;
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;
SP: PChar;
begin
asm mov ax,seg @data; mov ds,ax end;
ExpectBlock:=1;
SP:=GlobalLock(hBuffer);
I:=0;
repeat
ok:=ReadBlock(BlkNr,buf);
vsrec.bn:=BlkNr;
if OK then begin
if (BlkNr=ExpectBlock) or (BlkNr=$FF) then begin
vsrec.ch:='>';
J:=0;
hmemcpy(SP,@buf,sizeof(buf));
Inc(BytesWritten,sizeof(buf));
IncHP(SP,sizeof(buf));
if (BlkNr=$FF) and (ExpectBlock<>$FF) then begin
GlobalUnlock(hBuffer);
EndProcess1(true);
end;
Inc(ExpectBlock);
end else begin
vsrec.ch:='*';
J:=4;
end;
end else begin
vsrec.ch:='?';
J:=4;
end;
if (J=0) and (BlkNr=1) and (I=0) then begin
SP2:=PChar(@buf);
I:=wvsprintf(S,'%11.11s ',SP2);
end;
wvsprintf(S+I+J,'%02X%c ',vsrec);
PostMessage(MainWnd,WM_SetStatus,0,LongInt(@S));
until false;
end;
procedure WriteByte(B:Byte);
var
I,W:Integer;
begin
for I:=0 to 7 do begin
W:=f2400;
if B and 1 <>0 then W:=f1200;
WriteSwing2(W);
B:=B shr 1;
end;
WriteSwing2(f0600);
end;
procedure WriteBlock(BlkNr:Byte; const Buffer:TBlock; Vorton:Integer);
{Kontext: MMTASK.TSK}
var
I,W:Integer;
B,Sum:Byte;
begin
for I:=1 to Vorton do WriteSwing2(f1200); {Vorton}
WriteSwing2(f0600); {Trennzeichen}
WriteByte(BlkNr);
Sum:=0;
for I:=0 to $7F do begin
Inc(Sum,Buffer[I]);
WriteByte(Buffer[I]);
end;
WriteByte(Sum);
end;
procedure WriteDataKCC; far;
{Kontext: MMTASK.TSK, Routine beendet die Task}
{Schreibt BytesToWrite Bytes aus dem hBuffer}
var
CurBlk: Byte;
S: array[0..31] of Char;
I: Integer;
buf: TBlock;
SP: PChar;
Erster_Block, Letzter_Block: Boolean;
begin
asm mov ax,seg @data; mov ds,ax; int 3 end;
CurBlk:=1;
SP:=GlobalLock(hBuffer);
BytesWritten:=0;
Erster_Block:=true;
Letzter_Block:=false;
Amp:=127;
repeat
I:=sizeof(buf);
if BytesToWrite<=I then begin
I:=LongRec(BytesToWrite).Lo;
if not Erster_Block then begin
if CurBlk<>$FF then Letzter_Block:=true;
CurBlk:=$FF;
end;
end;
hmemcpy(@buf,SP,I);
Dec(BytesToWrite,I);
IncHP(SP,I);
I:=$A0;
if Erster_Block then I:=$A00;
WriteBlock(CurBlk,buf,I);
I:=CurBlk;
Inc(CurBlk);
wvsprintf(S,'%02X<',I);
PostMessage(MainWnd,WM_SetStatus,0,LongInt(@S));
Erster_Block:=false;
until Letzter_Block;
EndProcess1(true);
end;
function LoadFile:Boolean;
var
ofn: TOpenFileName;
S,SFilter: array[byte]of Char;
f: Integer;
Add: Integer; {0 oder 11}
pBuf: PChar;
C: Char;
begin
LoadFile:=false;
FillChar(ofn,sizeof(ofn),0);
with ofn do begin
lStructSize:=sizeof(ofn);
hWndOwner:=MainWnd;
hInstance:=Seg(HInstance);
lpstrFilter:=SFilter;
LoadString(Seg(HInstance),107,SFilter,sizeof(SFilter));
lpstrFile:=S;
nMaxFile:=sizeof(S);
S[0]:=#0;
Flags:=OFN_FileMustExist or OFN_ShowHelp
or OFN_LongNames or OFN_HideReadOnly;
{für Turbolader h#s und Z1013 Dateinamensinklusion weglassen}
if not GetOpenFileName(ofn) then exit;
Add:=0;
if Flags and OFN_ReadOnly <>0 then Add:=11;
f:=_lopen(S,0);
if f=-1 then exit;
BytesToWrite:=_llseek(f,0,2); {Dateilänge}
_llseek(f,0,0); {Zeiger zurück}
hBuffer:=GlobalAlloc(GMEM_MoveAble or GMEM_Share,BytesToWrite+Add);
pBuf:=GlobalLock(hBuffer);
if Add<>0 then asm
{Dateiname einbauen; dabei Name und Erweiterung mit Leerzeichen auffüllen.
Bei Erweiterungen mit 3 gleichen Buchstaben wird diese an den Anfang
gezogen und 80h addiert, als Extrawurst für BASIC-Programme und ~Daten}
cld
les di,[pBuf]
xor dx,dx {Merk-Register}
mov si,offset S
mov cx,[nFileExtension]
jcxz @@1 {keine Endung!}
add si,ax
segss lodsb {1. Zeichen der Endung}
cmp ss:[si],al
jnz @@1
cmp ss:[si+1],al
jnz @@1
or al,80h
stosb
stosb
stosb
inc dl {Kennungs-Bit}
@@1: mov si,offset S
add si,[nFileOffset]
mov cx,8
@@l1: segss lodsb
or al,al
jz @@2
cmp al,'.'
je @@2
stosb
loop @@l1
@@2: mov al,' '
rep stosb {Rest mit Leerzeichen auffüllen}
or dl,dl {Endung vorgezogen?}
jnz @@3
mov cx,3
mov si,offset S
mov ax,[nFileExtension]
or ax,ax {Keine Extension?}
jz @@2 {3 Bytes löschen!}
add si,ax
jmp @@l1 {Extension <blank-padded> anhängen}
@@3: end;
BytesWritten:=_hread(f,pBuf+Add,BytesToWrite);
GlobalUnlock(hBuffer);
if (_lclose(f)<>0) or (BytesWritten<>BytesToWrite) then begin
MBox1(MainWnd,105,S);
hBuffer:=GlobalFree(hBuffer);
exit;
end;
BytesWritten:=0;
LoadFile:=true;
end;
end;
function SaveFile:Boolean;
var
ofn: TOpenFileName;
S,SFilter: array[byte]of Char;
f: Integer;
Add: Integer; {0 oder 11}
pBuf: PChar;
C: Char;
begin
SaveFile:=false;
FillChar(ofn,sizeof(ofn),0);
with ofn do begin
lStructSize:=sizeof(ofn);
hWndOwner:=MainWnd;
hInstance:=Seg(HInstance);
lpstrFilter:=SFilter;
LoadString(Seg(HInstance),107,SFilter,sizeof(SFilter));
lpstrFile:=S;
nMaxFile:=sizeof(S);
Flags:=OFN_PathMustExist or OFN_ShowHelp or OFN_OverwritePrompt
or OFN_LongNames or OFN_HideReadOnly;
{für Turbolader h#s und Z1013 Dateinamensinklusion weglassen}
(* pBuf:=GlobalLock(hBuffer);
asm cld
push ds
lds si,[pBuf]
push ss
pop es
mov di,offset S
xor dx,dx
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}
@@2: loop @@l1
mov al,'.'
stosb {jetzt kommt die Extension!}
sub si,dx {Korrektur, wenn Extension vorn war!}
mov cx,3
@@l2: lodsb
and al,7Fh
cmp al,' '
jbe @@3
stosb
@@3: loop @@l2
xor al,al
stosb {Terminierende Null}
pop ds
end;
GlobalUnlock(hBuffer);*)
if not GetSaveFileName(ofn) then exit;
Add:=0;
if Flags and OFN_ReadOnly <>0 then Add:=11;
f:=_lcreat(S,0);
if f=-1 then exit;
pBuf:=GlobalLock(hBuffer);
Dec(BytesRead,Add);
BytesWritten:=_hwrite(f,pBuf+Add,BytesRead);
GlobalUnlock(hBuffer);
if (_lclose(f)<>0) or (BytesWritten<>BytesRead) then begin
MBox1(MainWnd,106,S);
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;
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;
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 EnableButtons;
{verwendet globale Variable Modus: =0: ENABLEd, <>0: DISABLEd}
begin
EnableWindow(GetDlgItem(MainWnd,1),Modus=0);
EnableWindow(GetDlgItem(MainWnd,22),Modus=0);
end;
procedure DoEndProcess(OK:Boolean);
begin
case Modus of
1: begin
WaveInReset(hWav); {Restliche (leere) Puffer "ausspucken"}
if WaveInClose(hWav)<>0 then asm int 3 end; {Gerät schließen}
if OK then SaveFile;
if hBuffer<>0 then hBuffer:=GlobalFree(hBuffer);
FreeWaveBlock(Waves[0]);
if WaveInDev<>-2 then FreeWaveBlock(Waves[1]);
end;
2: if not OK then begin
WaveOutReset(hWav); {im Abbruch-Fall}
if WaveOutClose(hWav)<>0 then asm int 3 end;
end;
end{case};
Modus:=0;
EnableButtons;
if hBuffer<>0 then hBuffer:=GlobalFree(hBuffer);
FreeWaveBlock(Waves[0]);
if WaveInDev<>-2 then FreeWaveBlock(Waves[1]);
end;
{
procedure PostApp(W:HWave; Msg:Word; Instance,Param1,Param2:LongInt); far;
begin
case Msg of
WOM_Done: PostAppMessage(Task,MM_WOM_Done,W,Param1);
WIM_Data: PostAppMessage(Task,MM_WIM_Data,W,Param1);
end;
end;
}
function LoadProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):Bool; export;
var
lPar: LongRec absolute lParam;
S: array[0..255] of Char;
SP: PChar;
Proc: TFarProc absolute SP;
W: Word;
I,J,K: Integer;
B: Bool absolute K;
WaveOutCaps: TWaveOutCaps absolute S;
WaveInCaps: TWaveInCaps absolute S;
WH: PWaveHdr absolute lParam;
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!}
PostMessage(Wnd,WM_ContinueInit,0,0);
end;
WM_ContinueInit: begin
UpdateWindow(Wnd); {würde in InitDialog nichts bringen !!}
SP:=nil;
if RegGetRoot('KCEMU\KCLOAD',S,sizeof(S)) then begin
SP:=S;
Installed:=true;
end;
Retries:=GetInt(SP,4);
Coding:=GetInt(SP,0);
WaveVol:=GetInt(SP,2);
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;
SendMessage(W,CB_SetCurSel,Coding,0);
SetDlgItemInt(Wnd,13,WaveVol,true);
W:=GetDlgItem(Wnd,14); {Handle Kombobox WaveIN}
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_1M08 <>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}
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;
end;
WM_EndProcess: DoEndProcess(Boolean(wParam));
WM_SetStatus: SetDlgItemText(Wnd,10,PChar(lParam));
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 WaveVol:=I;
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}
IDCancel: begin
LoadString(Seg(HInstance),110,S,sizeof(S));
SetDlgItemText(MainWnd,10,S);
case Modus of
0: EndDialog(Wnd,0); {Programm beenden}
1,2: PostAppMessage(Task,WM_Quit,0,0);
end
end;
1: if Modus=0 then begin {Datei einlesen}
hBuffer:=GlobalAlloc(GMEM_MoveAble or GMEM_Share,$8000);
BytesRead:=0;
asm int 3 end;
if WaveInDev=-2 then begin
hWav:=_lopen('test.raw',0);
I:=Integer(hWav<>0);
end else begin
I:=WaveInOpen(@hWav,WaveInDev,PWaveFormat(@MyWav),
Wnd,0,Callback_Window);
end;
if I=0 then begin
Modus:=1;
EnableButtons;
WaveInAddbuffer(hWav,MakeWaveBlock(Waves[0]),sizeof(TWaveHdr));
CurWaveHdr:=MakeWaveBlock(Waves[1]);
ByteIndex:=$FFFF;
WaveInStart(hWav);
case coding of
0: Proc:=@ReadDataKCC;
{ 1: Proc:=@ReadDataMPMTurbo;
4: Proc:=@ReadDataBasicode;}
end;
if MMTaskCreate(Proc,Task,LongInt(@CurWaveHdr))<>0 then asm int 3 end;
end else begin
HandleMMError(I);
hBuffer:=GlobalFree(hBuffer);
end;
end;
22: if Modus=0 then begin {Datei laden und ausgeben}
if not LoadFile then exit;
if WaveOutDev=-2 then begin
hWav:=_lcreat('test.raw',0);
I:=Integer(hWav<>0);
end else begin
I:=WaveOutOpen(@hWav,WaveOutDev,PWaveFormat(@MyWav),
Wnd,0,Callback_Window);
end;
if I=0 then begin
Modus:=2;
EnableButtons;
CurWaveHdr:=MakeWaveBlock(Waves[0]);
ByteIndex:=0;
case coding of
0: Proc:=@WriteDataKCC;
{ 1: Proc:=@WriteDataMPMTurbo;
4: Proc:=@WriteDataBasicode;}
end;
if MMTaskCreate(Proc,Task,LongInt(@CurWaveHdr))<>0 then asm int 3 end;
if WaveOutDev<>-2
then PostAppMessage(Task,MM_WOM_Done,hWav,
LongInt(MakeWaveBlock(Waves[1])));
end else begin
HandleMMError(I);
hBuffer:=GlobalFree(hBuffer);
end;
end;
end{WM_Command};
MM_WOM_Done,MM_WIM_Data: PostAppMessage(Task,Msg,wParam,lParam);
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}
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;
exports
ReadSwing index 2,
WriteSwing index 3,
EndProcess index 4;
begin
LoadString(Seg(HInstance),100,AppName,sizeof(AppName));
WUtils.StdMBoxTitle:=AppName; {MessageBox-Titel in Unit setzen}
if HPrevInst<>0 then begin {Nicht doppelt starten!}
ShowWindow(FindWindow('KCLOAD',nil),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.
{ with DEN do begin
case coding of
0: begin X:=0;F:=f1200;T:=0;W:=44;N:=1;end;
1: begin X:=10;F:=f2000;T:=0;W:=16;N:=1;end;
4: begin X:=40;F:=f2400;T:=F;W:=18;W:=M;end;
end;
A:=WaveVol*18;
end;}
{ with DEN do begin
case coding of
0: begin X:=0;F:=f1200;T:=F;W:=1000;N:=1;end;
1: begin X:=10;F:=f2000;T:=F;W:=8000;N:=1;end;
4: begin X:=40;F:=f2400;T:=F;W:=8000;end;
end;
A:=WaveVol*18;
end;}
function FrqToBit(Halb:Boolean):Boolean;
begin
with DEN do begin
FrqToBit:=false;
if ((Z>1) and odd(Z)) or Halb then begin
B:=B SHR 1;
if T>F*1.4 then B:=B or $80;
end;
dec(Z);T:=1;
if Z=0 then begin
FrqToBit:=true;dec(D);
if halb then Z:=8 else Z:=18;end;
end;
end;
function DecodeBlock(Data:PChar; DataLen:Word):Boolean;
var
pBuf:PChar;
J:integer;
begin
DecodeBlock:=true; {weitere Blöcke folgen}
for I:=0 to DataLen-1 do with DEN do begin
if (byte(Data[I])<$80) xor (A<0) then inc(T) else begin
A:=-A;
case X of
0: begin {44 Vortonschwingungen prüfen}
if (T<F*0.8) or (T>F*1.4) then W:=44 else begin
dec(W);if W=0 then begin X:=1;F:=f0600;W:=2;
end;
end;
T:=1;
end;
1: begin {2 Trennzeichen prüfen}
if T>F*0.8 then begin
dec(W);
if W=0 then begin X:=2;F:=f2400;Z:=18;D:=129;C:=0;end;
end else W:=2;
T:=1;
end;
2: begin {Byte einlesen}
if D=129 then begin
if FrqToBit(false) then M:=B;
end
else begin
if D>0 then begin
if FrqToBit(false) then begin
Inc(C,B);
Buf[127-D]:=B;
end;
end
else begin {D=0}
if FrqToBit(false) then begin
if C=B then begin
if M=$FF then begin N:=M;DecodeBlock:=false;end;
if M=1 then begin {KonvName;Pos:=12;}end;
if M=N then begin
Disp[0]:=Char(Hex[M div 16]);
Disp[1]:=Char(Hex[M mod 16]);
Disp[2]:='>';inc(N);
Disp[3]:=#0;
pBuf:=GlobalLock(hBuffer);
for J:=0 to 127 do pBuf[Bytesread+J]:=Char(buf[J]);
GlobalUnlock(hBuffer);
inc(BytesRead,$80);
end
else begin
Disp[3]:=' ';
Disp[4]:=Char(Hex[M div 16]);
Disp[5]:=Char(Hex[M mod 16]);
Disp[6]:='*';
Disp[7]:=#0;
end;
end
else begin
Disp[3]:=' ';
Disp[4]:=Char(Hex[M div 16]);
Disp[5]:=Char(Hex[M mod 16]);
Disp[6]:='?';
Disp[7]:=#0;
end;
SetDlgItemText(MainWnd,10,Disp);
X:=0;F:=f1200;T:=1;W:=44;
end;
end;
end;
end;
10: begin {40 Vortonschwingungen prüfen}
if (T<F*0.7) or (T>F*1.5) then W:=10 else begin
dec(W);if W=0 then begin X:=11;F:=f1000;W:=2;
end;
end;
T:=1;
end;
11: begin {2 Trennzeichen prüfen}
if T>F*0.8 then begin
dec(W);
if W=0 then begin X:=12;F:=f2000;Z:=8;D:=129;C:=0;
end;
end else W:=2;
T:=1;
end;
12: begin {Byte einlesen}
if D=129 then begin
if FrqToBit(true) then M:=B;
end
else begin
if D>0 then begin
if FrqToBit(true) then begin
C:=C xor B;
Buf[127-D]:=B;
end;
end
else begin {D=0}
if FrqToBit(true) then begin
if C=B then begin
if M=$FF then begin N:=M;DecodeBlock:=false;end;
if M=1 then begin {KonvName;Pos:=12;}end;
if M=N then begin
J:=M;
wvsprintf(Disp,'%02X> ',J);
pBuf:=GlobalLock(hBuffer);
for J:=0 to 127 do pBuf[Bytesread+J]:=Char(buf[J]);
GlobalUnlock(hBuffer);
inc(BytesRead,$80);
end
else begin
J:=M;
wvsprintf(@Disp[4],'%02X*',J);
end;
end
else begin
J:=M;
wvsprintf(@Disp[4],'%02X?',J);
end;
SetDlgItemText(MainWnd,10,Disp);
X:=10;F:=f2000;T:=1;W:=10;
end;
end;
end;
end;
end;{end case}
end;
end;
end;
procedure BitToFrq;assembler;
asm
mov [DEN.W],2
dec [DEN.Z]
ror [DEN.B],1
jc @@1
mov [DEN.F],f2400
mov [DEN.T],f2400
jmp @@2
@@1: mov [DEN.F],f1200
mov [DEN.T],f1200
@@2: end;
procedure BitToFrq1;assembler;
asm
mov [DEN.W],1
dec [DEN.Z]
ror [DEN.B],1
jc @@1
mov [DEN.F],f2000
mov [DEN.T],f2000
jmp @@2
@@1: mov [DEN.F],f1000
mov [DEN.T],f1000
@@2: end;
procedure BitToFrq4;assembler;
asm
mov [DEN.W],2
dec [DEN.Z]
ror [DEN.B],1
jc @@1
mov [DEN.F],f2400
mov [DEN.T],f2400
jmp @@2
@@1: mov [DEN.F],f1400
mov [DEN.T],f1400
@@2: end;
function EncodeBlock(Data:PChar; var DataLen:Word):Boolean;
begin
for I:=0 to DataLen-1 do with DEN do begin
Data[I]:=Char(A+$80);
dec(T);
if T=0 then begin A:=0-A;T:=F;dec(W);end;
if W=0 then case X of
0: begin {Vorton, danach Trennzeichen}
X:=1;F:=f0600;T:=F;W:=2;D:=129;
end;
1: begin {Trennzeichen, danach Byte}
if D=129 then begin X:=2;B:=N;Z:=8;BitToFrq;C:=0;
Str(N:3,S);StrCat(S,'<');
SetDlgItemText(MainWnd,10,S);
inc(N);
end else
if D=0 then begin X:=3;B:=C;Z:=8;BitToFrq;end
else begin X:=2;B:=random(256);Inc(C,B);Z:=8;BitToFrq;end;
end;
2: begin {Byteausgabe: Blk-Nr,Data}
if Z=0 then begin X:=1;dec(D);F:=f0600;T:=F;W:=2;end
else BitToFrq;
end;
3: begin {Byteausgabe: CRC}
if Z=0 then begin X:=4;F:=f0100;T:=F;W:=1;end
else BitToFrq;
end;
4: begin {Trennzeichen, danach Vorton}
X:=0;F:=f1200;T:=F;W:=320;
end;
10: begin {Vorton, danach Trennzeichen}
X:=11;F:=f1000;T:=F;W:=2;D:=129;
end;
11: begin {Trennzeichen, danach Byte}
X:=12;B:=N;Z:=8;BitToFrq1;C:=0;
Str(N:3,S);StrCat(S,'<');
SetDlgItemText(MainWnd,10,S);
inc(N);
end;
12: begin {Byteausgabe: Blk-Nr,Data}
if Z=0 then begin dec(d);
if D=0 then begin X:=13;B:=C;Z:=8;BitToFrq1;end
else begin B:=random(255);C:=C+B; Z:=8;BitToFrq1;end;end
else BitToFrq1;
end;
13: begin {Byteausgabe: CRC}
if Z=0 then begin X:=14;F:=f0100;T:=F;W:=1;end
else BitToFrq1;
end;
14: begin {Trennzeichen, danach Vorton}
X:=10;F:=f2000;T:=F;W:=210;
end;
40: begin {Vorton, danach 2 Trennzeichen}
X:=41;F:=f1400;T:=F;W:=4;
end;
41: begin {2 Trennzeichen, danach Byte}
X:=42;B:=random(95)+32;Z:=7;BitToFrq4;C:=0;
end;
42: begin {Prüfbit, danach Byte}
if Z=0 then begin X:=41;Z:=1;BitToFrq4;end
else BitToFrq4;
end;
end;
end;
EncodeBlock:=true; {weitere Blöcke folgen}
end;
| Detected encoding: OEM (CP437) | 1
|
|
|