Quelltext /~heha/hs/kcemu/kcemusrc.zip/LOAD.PAS

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;
Vorgefundene Kodierung: OEM (CP437)1
Umlaute falsch? - Datei sei ANSI-kodiert (CP1252)