{$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.
| Detected encoding: OEM (CP437) | 1
|
|
|