Quelltext /~heha/hs/bitcalc.zip/BITCALC.PAS

{$A+,B-,G+,F-,K+,W-}		{Standard-Codeerzeugung}
{$P-,T-,V+,X+}			{Compiler-Prüfungen}
{$IFOPT D+}
{$I+,L+,Q+,R+,S+,Y+}	 	{Debug-Codeerzeugung}
{$ELSE}
{$I-,L+,Q-,R-,S-,Y-}	 	{Release-Codeerzeugung}
{$ENDIF}
{$N+,E+}			{TReal=Single, lassen WINEM87.DLL arbeiten}
{$M $3000,$1000}		{Heap wächst notfalls von selbst}
program BitCalc;
{$C MOVEABLE PRELOAD PERMANENT}	{gleiche Attribute wie Unit SYSTEM}
{$D Serielle Bytestrom-Ausgabe für ICD2053 am seriellen Port, h#s (09/02)}
{$R bitcalc}
{$S $8000} {Units zusammenfassen minimiert Far-Calls}

uses
 WinProcs, WinTypes, Win31, WUtils;

type
 PReal=^TReal;
 TReal=Single;	{Globale Festlegung des verwendeten Gleitkomma-Formats}

const
{diverse Strings}
 AppName='BitCalc';		{auch: Klassenname des Haupt-Dialogfensters}
 Profile='BitCalc.INI';		{Name Initialisierungsdatei}
 Section='BitCalc';		{Sektion innerhalb}

var
 MainWnd: HWnd;
const
 OFreq: TReal=10;
 RFreq: TReal=10;
 CommName:array[0..4]of Char='COM1'#0;	{String-basiert}
 Cid: Integer=-1;	{Kommunikations-Handle: Noch jungfräulich}

{Serielle Daten zum ICD2053:
 ICD Pin2 = SCLK = /RTS = SubD9 Pin7 = SubD25 Pin4
 ICD Pin4 = DATA = /DTR = SubD9 Pin4 = SubD25 Pin20
 eine Rücklesemöglichkeit besteht leider nicht.
}

{***************************************************************************}

procedure SendICD(OBits:LongInt; nBits:Integer);
 begin
  while nbits<>0 do begin
   EscapeCommFunction(Cid,IfThenElse(Bool(OBits and 1),SETDTR,CLRDTR));
   EscapeCommFunction(Cid,SETRTS);
   EscapeCommFunction(Cid,CLRRTS);
   OBits:=OBits shr 1;
   Dec(nBits);
  end;
 end;

procedure InitICD;
 begin
  EscapeCommFunction(Cid,CLRRTS);
 end;

type
 Tpqmi=record
  p,q,m,i:Integer;
 end;

function GetPQMI(fOUT,fREF:TReal;fIST:PReal;var out:TPQMI):Boolean;
{Berechnet p, q, m und i aus der gewünschten und der
 Referenzfrequenz, letztere muss zwischen 1 und 25 MHz liegen.
 Liefert FALSE bei falschen Eingangsparametern, aber auch bei
 algorithmischer Unerreichbarkeit von fOUT (z.B. fOUT=6, fREF=1).}
 label rept;
 var
  fINT,pq,f,ff: TReal;		{fINT in MHz}
  imm: TPQMI;
 begin
  GetPQMI:=false;
  {0. Randbedingungen prüfen}
  if fOUT<50/128 then exit;	{geht nicht}
  if fOUT>150 then exit;	{geht nicht}
  if fREF<1 then exit;
  if fREF>25 then exit;
  {1. M (Ausgabe-Multiplexer) ermitteln (ggf. in 2 Runden) }
  f:=1E30;			{Abweichung zur Minimumsuche}
  fINT:=fOUT; imm.m:=0;
  while fINT<50 do begin
rept:
   fINT:=fINT+fINT;
   Inc(imm.m);
  end;
  imm.i:=IfThenElse(fINT>=80,8,0);
  {2. P und Q (Teiler) ermitteln bei kleinstem Fehler}
  pq:=fINT/(fREF*2);	{gebrochenes Teilerverhältnis}
  for imm.q:=3 to 129 do begin	{alle Q probieren}
   if fREF/imm.q>1.0 then continue;{Q noch zu klein, ergibt zu großes fREF/Q}
   if fREF/imm.q<0.2 then break;{Q zu groß, ergibt zu kleines fREF/Q}
   imm.p:=Round(pq*imm.q);	{passendes P ermitteln}
   ff:=Abs(imm.p/imm.q-pq);	{Fehler ermitteln}
   if (imm.p>=4) and (imm.p<=130) and (ff<f) then begin	{neuer Bestwert?}
    out:=imm;
    f:=ff;			{Bestwert sichern}
    if f=0 then break;		{geht nicht besser}
   end;
  end;
  if fINT<=75 then goto rept;	{noch eine Verdopplung ist möglich}
  if f>1E29 then exit;		{da geht etwas algorithmisch nicht}
  {3. Istfrequenz ermitteln}
  if fIST<>nil then begin
   fIST^:=2*fREF*out.p/out.q;
   for imm.m:=out.m downto 1 do fIST^:=fIST^/2;
  end;
  GetPQMI:=true;
 end;

function myBitCalc(fOUT,fREF:TReal;fIST:PReal;Obits:PLongInt):Integer;
{wie BitCalc, berechnet Bitkette gewünschten und der Referenzfrequenz}
 var
  bits,mask: LongInt;
  bitslo: Word absolute bits;
  PQMI: Tpqmi;
 begin
  {1.-3. siehe oben}
  myBitCalc:=0;
  if not GetPQMI(fOUT,fREF,fIST,PQMI) then exit;
  {4. Bitkette zusammenstellen}
  bitslo:=pqmi.p-3;			{7 P'}
  bitslo:=bitslo shl 1 or 1;		{1 D}
  bitslo:=bitslo shl 3 or pqmi.m;	{3 M}
  bits  :=bits   shl 7 or (pqmi.q-2);	{7 Q'}
  bits  :=bits   shl 4 or pqmi.i;	{4 I}
  {5. Bitkette stuffen}
  if OBits<>nil then asm
	les	di,[OBits]
	mov	ax,22
	mov	cx,ax
	mov	dl,3
@@l1:	shr	LongRec[bits].hi,1
	rcr	LongRec[bits].lo,1
	jnc	@@zerobit
	rcr	es:LongRec[di].hi,1
	rcr	es:LongRec[di].lo,1
	dec	dl
	jnz	@@nostuff
	inc	ax
@@zerobit:
	mov	dl,3
	shr	es:LongRec[di].hi,1
	rcr	es:LongRec[di].lo,1
@@nostuff:
	loop	@@l1
	mov	cl,32
	sub	cx,ax
	jcxz	@@e
@@l2:	shr	es:LongRec[di].hi,1	{LSB ausrichten}
	rcr	es:LongRec[di].lo,1
	loop	@@l2
@@e:	mov	[@Result],ax
  end;
 end;

procedure ShowBits(OBits:LongInt; nBits:Integer);
{Bit-Kette im Editfenster darstellen}
 var
  s: TS31;
  m: LongInt;
  sp: PChar;
 begin
  m:=LongInt(1) shl (nBits-1);
  sp:=s;
  repeat
   sp^:='0';
   if OBits and m <>0 then Inc(sp^);
   Inc(sp);
   m:=m shr 1;
  until m=0;
  sp^:=#0;
  SetDlgItemText(MainWnd,117,s);
 end;

function Real2S(Z:TReal; F:Integer; S:PChar):PChar;
{Diese Funktion arbeitet wie Str(Z:F:F,S), jedoch werden unnötige
 Nachkomma-Nullen abgeschnitten.
 Als Ergebnis wird der Stringzeiger durchgereicht.
 Str() will die Größe des Strings haben (= offenes Array);
 daher muß mit einem wilden Typecast der Compiler ruhiggestellt werden}
 begin
  Real2S:=S;		{Stringzeiger durchreichen}
  Str(Z:F:F,TS255(Pointer(S)^));	{mittels Systemfunktion wandeln}
  S:=lStrChr(S,'.');	{Dezimalpunkt enthalten?}
  if S<>nil then begin
   Inc(S,lstrlen(S));	{Auf die Null}
   repeat
    Dec(S);		{Zeiger aufs Stringende (vor die Null)}
    if S^='.' then begin {String besteht nur (noch) aus dem Dezimalpunkt?}
     S^:=#0;		{String kürzen und raus!}
     break;
    end;
    if S^='0' then S^:=#0	{Stringende ist die Null? - Kürzen und weiter}
    else break;		{sonst raus!}
   until false;
  end;
 end;

function S2Real(S:PChar; var Z: TReal):boolean;
{wie Val(), jedoch vorher Komma zu Punkt wandeln.
 Das Ergebnis ist TRUE, wenn die Konversion OK verlief; dann und nur dann
 wird auch die Variable Z eingeschrieben.
 Weißraum (TAB & SPC) am Anfang wird übergangen, Weißraum (#0..' ')
 am Ende auch, beim Abhacken wird das Zeichen zwischendurch gemerkt,
 d.h. der String S wird nicht nach außen verändert.
 Da die dusselige Pascal-Val()-Funktion bei Fehler 0.0 einschreibt,
 geht's nicht ohne Umweg über eine lokale Real-Variable.
 Ein Jammer, daß weder Windows noch Pascal vernünftiges Handling mit
 Real-Zahlen anbieten}
 var
  I:Integer;
  SP: PChar;
  MemChr: Char;
  ZT: TReal;
 begin
  while (S^=' ') or (S^=#9) do Inc(S);	{Weißraum am Anfang übergehen}
  SP:=lStrChr(S,',');
  if SP<>nil then SP^:='.';	{Komma zum Punkt machen}
  SP:=S;
  while SP^>' ' do Inc(SP);	{Ende des Strings suchen}
  MemChr:=SP^; SP^:=#0;		{Zeichen merken, String abhacken}
  Val(S,ZT,I);
  SP^:=MemChr;			{Zeichen zurückschreiben}
  if I=0 then Z:=ZT;		{Nur bei fehlerfreier Konversion rückschreiben}
  S2Real:= (I=0);		{false wenn Fehler in Real-Zahl}
 end;

procedure SetReal(ToID: Word; X: TReal; nk: Integer);
 var
  S: TS31;
 begin
  Real2S(X,nk,S);
  SetDlgItemText(MainWnd,ToID,S);
 end;

function SetICD:Boolean;
 var
  IFreq,error:TReal;
  OBits:LongInt;
  nBits:Integer;
 begin
  SetICD:=false;
  nBits:=myBitCalc(OFreq,RFreq,@IFreq,@OBits);
  if nBits=0 then begin
   SetDlgItemText(MainWnd,103,'?');
   SetDlgItemText(MainWnd,104,'?');
   SetDlgItemText(MainWnd,117,'?');
   exit;
  end;
  SetReal(103,IFreq,6);
  SetReal(104,Abs((IFreq-OFreq)/OFreq)*1E6,1);
  ShowBits(OBits,nBits);
  SetICD:=true;
  if Cid<0 then exit;
  SendICD($1E25,14);	{CLKOUT=fREF}
  SendICD(OBits,nBits);
  SendICD($1E24,14);	{Programm-Register sperren}
  SendICD($1E20,14);	{CLKOUT=fVCO}
 end;


function SetComNo(AComNo:Integer):Boolean;
 begin
  SetComNo:=true;			{optimistisch}
  if Cid>=0 then begin
   CloseComm(Cid);	{falls noch offen: Kanal schließen}
   Cid:=-1;
  end;
  if AComNo=-1 then exit;
  CommName[3]:=Chr(AComNo+Byte('1'));	{Zeichen einsetzen}
  repeat
   Cid:=OpenComm(CommName,16,16);	{Kanal öffnen (Versuch)}
   if Cid>=0 then exit;
   case MBox2(MainWnd,107,MB_AbortRetryIgnore or MB_IconQuestion,
     PChar(Cid),CommName) of
    IDAbort: break;
    IDIgnore: begin Cid:=AComNo; exit; end;
   end;
  until false;
  SetComNo:=false;
 end;

function LoadConfig:Boolean;
{liefert FALSE wenn Schnittstellen-Eintrag ungültig}
 var
  I: Integer;
  P: TPoint;
  Z: TReal;
  S: TS31;
 function GPPS(key:PChar):Boolean;
  begin
   GPPS:=GetPrivateProfileString(Section,key,'',S,sizeof(S),StdProfile)>0;
  end;
 function GPPI(key:PChar; default: Integer):Integer;
  begin
   GPPI:=GetPrivateProfileInt(Section,key,default,StdProfile);
  end;
 begin
  LoadConfig:=true;
  if not IsIconic(MainWnd) then begin
   P.x:=GPPI('X',CW_UseDefault);
   P.y:=GPPI('Y',CW_UseDefault);
   if P.x<>CW_UseDefault then SetWindowPos(MainWnd,0,P.x,P.y,0,0,
     SWP_NoZOrder or SWP_NoSize);
  end;
  I:=GPPI('COM',0)-1;
  if (I>=0) and not SetComNo(I) then LoadConfig:=false;

  if GPPS('OFreq') and not S2Real(S,OFreq) then LoadConfig:=false;
  if GPPS('RFreq') and not S2Real(S,RFreq) then LoadConfig:=false;
 end;


function SaveConfig:Boolean;
{Speichern aller Zahlenwerte - außer Winkel?}
 var
  b: Bool;
  R: TRect;
  S: TS31;
 procedure WPPS(key:PChar);
  begin
   b:=WritePrivateProfileString(Section,key,S,StdProfile) and b;
  end;
 procedure WPPI(key:PChar; value: Integer);
  begin
   wvsprintf(S,'%d',value); WPPS(key);
  end;
 procedure WPPR(key:PChar; Z: TReal; nk: Integer);
  begin
   Real2S(Z,nk,S); WPPS(key);
  end;
 begin
  b:=true;
  if not IsIconic(MainWnd) then begin
   GetWindowRect(MainWnd,R);
   WPPI('X',R.left);
   WPPI('Y',R.top);
  end;
  WPPI('COM',Cid+1);
  WPPR('OFreq',OFreq,6);
  WPPR('RFreq',RFreq,6);
  if not b then MBox1(MainWnd,106,MB_Sound or MB_IconInformation,StdProfile);
  SaveConfig:=b;
 end;


procedure ScrollNumber(Wnd:HWnd; u,o,x:TReal; nk: Integer);
{Inkrementiert ein Editfeld <Wnd> um <x> unter Beachtung der Limits
 <u> und <o>; die Zahlenausgabe erfolgt mit <nk> Nachkommastellen}
 var
  Z,ZB: TReal;
  S: TS31;
 begin
  SetFocus(Wnd);
  GetWindowText(Wnd,S,sizeof(S));
  if S2Real(S,Z) then begin
   ZB:=Z;
   Z:=Z+x;
   if Z>o then Z:=o;
   if Z<u then Z:=u;
   if Z=ZB then MessageBeep(MB_IconStop)	{Ende erreicht}
  end else Z:=(u+o)/2;		{Mittlerer Wert falls Editfeld ungültig}
  Real2S(Z,nk,S);
  SetWindowText(Wnd,S);
 end;

var
 DefEditProc: TFarProc;

function OFreqSub(Wnd:HWnd;Msg,wParam:Word;lParam:LongInt):LongInt; export;
{Unterklassenfunktion für Editfenster "Winkel"}
 var
  I: Integer;
  Z: TReal;
 begin
  OFreqSub:=0;
  I:=Msg2VScroll(Msg,wParam,10);
  if I<>0 then begin
   Z:=I;
   if GetKeyState(VK_Shift) and $FE <>0 then Z:=Z/10;
   ScrollNumber(Wnd,50/128,100,Z,6)
  end else OFreqSub:=CallWindowProc(DefEditProc,Wnd,Msg,wParam,lParam);
 end;

function RFreqSub(Wnd:HWnd;Msg,wParam:Word;lParam:LongInt):LongInt; export;
{Unterklassenfunktion für Editfenster "Pulslänge"}
 var
  I: Integer;
  Z: TReal;
 begin
  RFreqSub:=0;
  I:=Msg2VScroll(Msg,wParam,10);
  if I<>0 then begin
   Z:=I;
   if GetKeyState(VK_Shift) and $FE <>0 then Z:=Z/10;
   ScrollNumber(Wnd,1,25,Z,6)
  end else RFreqSub:=CallWindowProc(DefEditProc,Wnd,Msg,wParam,lParam);
 end;

function MainDlgProc(Wnd:HWnd; Msg,wParam:Word; lParam: LongInt):Bool; export;
 var
  wParID: Word absolute wParam;
  lPar: LongRec absolute lParam;
  lParWnd: HWnd absolute lParam;
  dis: PDrawItemStruct absolute lParam;
  hi: PHelpInfo absolute lParam;
  I,K,ec: Integer;
  sysm: HMenu;
  Z: TReal;
  SP1: PChar;
  S,s2: TS31;
  w: HWnd;
  vsrec: record
   comno:Integer;
   addr: Word;
  end;
 begin
  MainDlgProc:=false;
  case Msg of
   WM_InitDialog: begin
    MainWnd:=Wnd;
    DefEditProc:=TFarProc(GetWindowLong(GetDlgItem(Wnd,101),GWL_WndProc));
    SetWindowLong(GetDlgItem(Wnd,101),GWL_WndProc,LongInt(@OFreqSub));
    SetWindowLong(GetDlgItem(Wnd,102),GWL_WndProc,LongInt(@RFreqSub));
    sysm:=GetSystemMenu(Wnd,false);
    DeleteMenu(sysm,SC_Maximize,0);
    DeleteMenu(sysm,SC_Size,0);
    i:=LoadString(Seg(HInstance),65,S,sizeof(S));
    sp1:=s;
    w:=GetDlgItem(Wnd,100);
    SendMessageP(w,CB_AddString,0,sp1);
    Inc(sp1,lstrlen(sp1)+1);
    k:=EscapeCommFunction(0,GetMaxCom);
    for i:=0 to k do begin
     vsrec.comno:=i+1;
     vsrec.addr:=Word(EscapeCommFunction(i,GetBaseIrq));
     wvsprintf(s2,sp1,vsrec);
     SendMessageP(w,CB_AddString,0,@s2);
    end;
    if not LoadConfig
    then MBox1(Wnd,105,MB_Sound or MB_IconInformation,StdProfile);
    SendMessage(W,CB_SetCurSel,Cid+1,0);
    SetReal(101,OFreq,6);
    SetReal(102,RFreq,6);
    ShowWindow(Wnd,CmdShow);
    MainDlgProc:=true;
   end;

   WM_Command: case wParID of
    100: if (lPar.Hi=CBN_SelChange)
    and SetComNo(SendMessage(lParWnd,CB_GetCurSel,0,0)-1)
    and (Cid>=0)
    then SetICD;
    101,102: if lPar.Hi=EN_Change then begin
     GetWindowText(lParWnd,S,sizeof(S));
     if S2Real(S,Z) then begin
      case wParID of
       101: begin
	OFreq:=Z;
	SetICD;
       end;
       102: begin
	RFreq:=Z;
	SetICD;
       end;
      end;
     end;
    end;
   end;

   WM_Close: begin		{hier: ohne WM_QueryEndSession}
    SaveConfig;
    EndDialog(Wnd,0);		{Fenster schließen}
   end;

  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_Window;
  lpszMenuName: MakeIntResource(100);
  lpszClassName: AppName
 );

begin
 if HPrevInst<>0 then begin
  MainWnd:=MemW[HPrevInst:Ofs(MainWnd)];
  if MainWnd<>0 then begin
   ShowWindow(MainWnd,SW_Show);
   SetActiveWindow(MainWnd);
  end;
  exit;
 end;
 wc.hIcon:=LoadIcon(Seg(HInstance),MakeIntResource(100));
 wc.hCursor:=LoadCursor(0,IDC_Arrow);
 RegisterClass(wc);
 StdProfile:=Profile;
 DialogBox(Seg(HInstance),MakeIntResource(100),0,@MainDlgProc);
end.
Vorgefundene Kodierung: OEM (CP437)1
Umlaute falsch? - Datei sei ANSI-kodiert (CP1252)