`8NNNNNN,p Hy NMHz<<b Hz`&O`?< NA.KNu (Ver. 18.4.91) p Hello !! I am your personal boot sector GUARDIAN As long as I display this message YOUR BOOT SECTOR IS NOT INFECTED BY ANY VIRUS --------------------------------------- This guardian was placed on your diskette by FASTCOPY PRO (c) 1991 ICP Verlag, Martin Backschat q hK @`! #@%`'/1 3@5`7O/[cgmoOoy{} ` ` @ @ @ ` ǀ ɠ  O ׀ `Oo!Aa  Oa!!#%a')+/5a79;=?/CAEaGIMOQ!SAoWY[]/Oogkmq!sAuawy{}!Aa!Aa!Aa!AaAaǁɡ!Aa١!Aa @`! #@%`'/1 3@5`7O/[cgmoOoy{} ` ` @ @ @ ` ǀ ɠ  O ׀ `Oo!Aa  Oa!!#%a')+/5a79;=?/CAEaGIMOQ!SAoWY[]/Oogkmq!sAuawy{}!Aa!Aa!Aa!AaAaǁɡ!Aa١!AaFILEBROW  FIND  JUTILITY meKAPITEL3 bPP_BSP `g WURMIE .WCLOCK PAS Oz EYES PAS yGEMINIT PAS `DMSWEEPERHRD |BMSWEEPERI |gMSWEEPERPAS ؙWMSWEEPERRSC | TETRAX sEAD__METXT Us. 5e.. 5eAPPLICATPAS k\BROWSER HRD qBROWSER I rdBROWSER O sBROWSER RSC uBROWSERWPAS w!DIALOG PAS  FILEBROWPAS `K%FILES PAS GEMINIT PAS DMENU PAS RECEIVERPAS 0RESOURCEPAS *TEXTWINDPAS ]<WINDOWS PAS Pc. 5e.. 5eDIRSEARCPAS [ FIND PAS bSTRSEARCPAS \g . Zc.. ZcGEMINIT PAS `DJUTILITYH q)JUTILITYI q+zJUTILITYPAS W--JUTILITYRSC q JUTILITYRSD q . Zc.. ZcBED_COMP A_CPAS bOOP Y_PFA c PROG1 b TURTLE  _ WORTERAT b . Zc.. ZcDEFINE PAS eN@IFDEF PAS nN>IFNDEF PAS |N?IFOPT PAS NA. [c.. [cC C kME,C INC ݙMJ4C O bK8PAS PAS MIG. [c.. [cDYNOBJ PAS pbGFEHLER PAS yPB?KORREKT PAS KzPDOOPDEMO1PAS hOCOOPDEMO2PAS WaF. [c .. [c1MAL1 PAS YITWEXAMPLE PAS ZIUEXITPROCPAS /ca7FORWARD PAS XIWGEDICHT PAS XIX_GRUSS PAS 6ZIYDHELLO PAS dj\9INOUT PAS YIZ]MYFILE TXT HcV}MYFIRST PAS djh9MYSECONDPAS GZI]xPROCEXITPAS I^PROGEXITPAS I_jPROGHALTPAS I`VRUNERRORPAS ecj3SCHLEIF1PAS ociSCHLEIF2PAS ceIdWERTETABPAS PZIeoZAHLTAFLPAS cbZRATEN PAS cf. [c .. [cPROG1 PAS $LL@UNITEXAMPAS 2LM. [c .. [cC-KURVE PAS 'V9DDRACHEN PAS cV<HILBERT PAS VxKOCH PAS 'VKOCHRECTPAS V/RECHTECKPAS wWW: REKURSIVPAS |YW=SIERPINSPAS Q;TURTLES PAS H @!. \c .. \cLESEN PAS `sVN WORTE TXT `rVSWORTERATPAS rVQ. \c .. \cCALC ACC zz1CALC APP zz41CALC PAS x+*CALC TXT _?CALCRSC DEF yCALCRSC DFN ylCALCRSC HRD y$CALCRSC I yTCALCRSC O 'w_ CALCRSC RSC yCALCRSC RSD yFMRSC DEF X@FMRSC DFN X8FMRSC HRD XAFMRSC I XFMRSC O yadFMRSC RSC X.FMRSC RSD X@FREEMEM ACC l\d$FREEMEM APP l\Ad$FREEMEM PAS y "FREEMEM TXT ]HANDLER PAS gKOWINDOWSPAS `U%UHR ACC [\D'UHR APP [\KD'UHR PAS y$UHR TXT G^,UHRRSC DEF L-PUHRRSC DFN L.FUHRRSC HRD 5Q/KUHRRSC I 5Q0UHRRSC O ycUHRRSC RSC 4Q1bUHRRSC RSD L3P. \c.. \cBLUTO DOO Kq}GEMINIT PAS `DWURM DAT ˚ZeWURM LEV SiWURMIE PAS Tod`0NJ#0NNX@---------------- Pure Pascal for Atari STe/TT Version 1.0 (c) 1992 Pure Software GmbH ----------------3pT`BpVN ypV fJp^gaFaH ypZN Runtime error at offset $0123456789ABCDEFHP?< NA\ONuOAa09pTr Oa j OpB0a&yrJ g.Aa&9p^8<|;??<NAXOQ?<NAO Nur&H fr&os pR + Ым*@Ы,UC#pn"k" <*AYM#r.M// ?<?<JNAO #rpr+g|<fB k, AfE"H gJ"gJfJf`VARGV=XOA$H`JgBR@JfHR$H`A"HB0< c<"frJg "f`B(R@HQ"HJf*3rJ9s gB?< NA\O x"( e\$<dzet dn ehdbe\dVePdJeDd>e8 d2 e,`0e$ eeee e dB9s /?< NA\O#hr#nr#r#r#r#r#ra#pZHyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9rNu _0<Nh"ypnb0<Na#p^BgHz?<Ns`?9pT?<LNAJ9s g~p yrav#rp yrad#rp yraR#rp yra@#rp yra.#rp yra#rp yra #rNuH瀠>NMPO @$_NuHR!| 1|װr!A!A 1A!|E!JA4pxd2EN`QB$_Nup42<d0`QNupQNu?d~V@|| dp ys"HPcR42 hPb2f@? <aR g`00$ Cr$i!I!J#H%H$B#s1|2@| d($ "h$h#J%I#s$B@pXNu0#s1Ap@0Nu2 j||?dg0(Pf@|m$f`l$ Cr$i!J!I#H%H$BC0k?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~pJ@k hײeH&H(I6xc`p aQ`aQJypff (g "@N3pf KLNuC` rlCAS QSr QNuJypffn"( b2(f* (gHP"@N _3pffFJ f`2"("hg1` 1R!A<g̰< g(Nu$jD BJjD$HBJBf.$HBJBfH@B@H@$jDNuB@H@HB2@0H@0 H@`?BCdQCJkSCҁ[DCHAt4B@H@HBBHBHA60dSCp06`$jD BJjD$HBJBf$HBJBf $jDNuHBЂ$`HBЂ`p`QBNuJypff0"h"(R!A (Se (gHP"@N3pf _NuRHHPJ@l JAg-D@C&Ye2)t AUA 2f"_ Nu'd 09876543210a3pfNuJlD@| |l@0; `p`pNuHRHS&Hp'@'@'@ 0+|ױg$< 'B|ײf2<<`'| P'| dp`7|ײ2<=J+4gl$+4NULgVAUXgPRNgCONgDļLPTgtCOMgV'| ( ?Hk4?NAPOJl a 7|װ`6p&_$_Nup kױg$< 'B'B`'| B`+7<1SbJ+8fp`+7<1UbJ+8fp`HSHR&H??<>NAXOJ@f7|װp$_&_Nua`a< gpNuHRHP/(/(??<?NAO _$_JkH!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R AqapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fpfNu3ipfNuBBJAb 0 VDNuBNuBysByrAp,"@ "A3@@r"`"p"@ "1B3r"ONu/ Hz?<&NN\O$_NuJ9ro@'h0T Nu2<@Jg@jD|bH@|bQAbYAJkSAЀj0 BNuBA`|b @0; gaNuJ9roD/(/(Bg?H/)/)Bg?H8DNuDNuDNuDNuHHz `lp`N````` ` ``2NqNqNqJ@jR@fJjFFF@JCjRCfJjFFFCCg mB@DLxNup`p`6C`6*)<<HFFg6()kfJfU`SCڅلj0"$HFFgJjNuf4Jf0]Nu()fJfY`JfJf  Nu\HNuJkS@ԂӁjNu0<rtv`H@Frtv`<<6(FgF Cpn @b:H@@9s g 9s g 69s[Ck S@rt`rtv` @n0H@@rtv9s gv9s gl89s\Dj`t`PvxR@fЀP9s fg,` 9s g 9s gJ@k`J@j JgRdR !1.Nuv]H//?HW//0aPO0 ]H.NudNu/ f" H`@abL g" )k!LNu )k!LNu @NuJs fArBypTBpVBp^BypfBphplBPC!IC!I#sBsB9pmNbJyrgpmAprC*N6AprNAqCNAqNNuNVAspN* yuN!J9pRf AN,` ys gN,~#u,pVN^Nu #pVu,A#pVN,r3s Jys l3s p` |N"#u yupN"6#u$ yupN"6#u( yu$pCN+Au0C"^N"As"yu$N)VAs09N)\J9pRg$AsCDN)bJfp`0pN.`"09s A*N-:3sJyslp`pNu0 Sweetie Sweetie...cmrs(? / *-+ .0123456 7 8 9NVH8(I&H? yu$rt@AN-TO6 Cg<$|xRf*Sp*8HnHnACprtN,POXQLN^NuNV-X-X-X-X0.||b@0;NRx,@AsCN)b`AspN*`As0.N)LJgAsN(`J9pRgAs0.N)LJgrp`p`lAspN*`\As0.N)LJgHAs0.2.N't`2As0.N)LJg?.As0.2.4.N((TOpN^Nu Sweetie NVH. <.B* ??024N.XO5@0*J@l| `>2|JAgJ.cC AN, |JCgJ.c0*C AN,*LN^NuNVH *(&$H<.??0*24N.XOJ@l| LxN^Nu0(N.Nu/ $H0*N/5|$_NuNVH8(&$HGIHnHn0*ACrN/(PO?.?.?0*r4N/\\OHnHn0*ACrN/(PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN/\\ONuNVH<*(&$H<.GIKpN/HnHnACprN/(POHTHS0*ACr N/(PO`HnHn?????AC02.4N+nOJgXHnHn?.?.?.?.?.AC0.2.4.N+nOJg?.A0.2.4.N+4TOHTHS0*ACr N/(POJSoJTnXpN/LCu3@pg"<`(HQHPCu3@3Aph"<a "_2"_2"o2"o2NuCu222"2Cpi"<`Cu3@pk"<`HQHPCu222" 2Cpl"<a"_2"_2"o 2"o2NuH0JzfhNAuCzvEzbG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB" N       :^6(N@44* 40B(20`jZ8@  4 &          .p      2  x      Hj( $h(6*b( h4 .8N,.> v2HD  &4` (&&0"T 0$>2t`tSA Vf0NuepNupNu0(|װ|װfHS&H kװg + g "@N3ZRkB+ +g "@ KN3Z&_Nu <2(|װ|װftHSHR&H'@ kװg + g "@N3Z'| p'@'@B+9ZH?|ױ7@Hk4?<=NAPO6$_&_`0(|װ|װfHS&H kװg + g "@N3ZTkB+ +g "@ KN3Z&_Nu <2(|װ|װfHSHR&H'@ kװg + g "@N3ZVk'| p'@'@B+BgHk4?<?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~PROGRAM KochRechteck; USES Turtles; TYPE TurtleGraphik = OBJECT(Turtle) PROCEDURE KochRechteck(Grad, Seite : WORD); END; PROCEDURE TurtleGraphik.KochRechteck(Grad, Seite : WORD); VAR NeuSeite : WORD; BEGIN IF Grad = 0 THEN Forward(Seite) ELSE BEGIN DEC(Grad); NeuSeite := Seite DIV 3; SELF.KochRechteck(Grad, NeuSeite); Right(90); SELF.KochRechteck(Grad, NeuSeite); Left(90); SELF.KochRechteck(Grad, NeuSeite); Left(90); SELF.KochRechteck(Grad, NeuSeite); Right(90); SELF.KochRechteck(Grad, NeuSeite) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Default(975, 0, 180); MyTurtle.Hide; MyTurtle.KochRechteck(4, 2000); MyTurtle.Show; MyTurtle.Done END END..N`2AkB0.NlJg?.AkB0.2.4.NHTOpN^Nu FreeMem NVH E6<Q&EmV R0CNHnC R0NXO0HrN( R?0H R40HAkB0.2.NHTOLN^NuNV/ EmfPROGRAM Koch; USES Turtles; TYPE TurtleGraphik = OBJECT(Turtle) PROCEDURE Koch(Grad, Seite : WORD); END; PROCEDURE TurtleGraphik.Koch(Grad, Seite : WORD); VAR NeuSeite : WORD; BEGIN IF Grad = 0 THEN Forward(Seite) ELSE BEGIN DEC(Grad); NeuSeite := Seite DIV 3; SELF.Koch(Grad, NeuSeite); Right(60); SELF.Koch(Grad, NeuSeite); Left(120); SELF.Koch(Grad, NeuSeite); Right(60); SELF.Koch(Grad, NeuSeite) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Default(975, 0, 180); MyTurtle.Hide; MyTurtle.Koch(4, 2000); MyTurtle.Show; MyTurtle.Done END END.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.Jmrf$N NNNNNJgNNuz LB"F N       rB0B(0`jVH@    P(>j< v2HD  "` (&&0"T 0$:`PROGRAM Hilbert; USES Turtles; TYPE TurtleGraphik = OBJECT(Turtle) PROCEDURE Hilbert(Grad, Seite : WORD; r : BOOLEAN); END; PROCEDURE TurtleGraphik.Hilbert(Grad, Seite : WORD; r : BOOLEAN); VAR Richtung : INTEGER; BEGIN IF Grad > 0 THEN BEGIN IF r THEN Richtung := 1 ELSE Richtung := -1; DEC(Grad); Turn(-Richtung * 90); SELF.Hilbert(Grad, Seite, NOT(r)); Forward(Seite); Turn(Richtung * 90); SELF.Hilbert(Grad, Seite, r); Forward(Seite); SELF.Hilbert(Grad, Seite, r); Turn(Richtung * 90); Forward(Seite); SELF.Hilbert(Grad, Seite, NOT(r)); Turn(-Richtung * 90) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Default(-975, -975, 90); MyTurtle.Hide; MyTurtle.Hilbert(6, 25, TRUE); MyTurtle.Show; MyTurtle.Done END END."yn~b0<Na#nnBgHz?<Ns`?9nd?<LNAJ9qg~p ypav#pp ypad#pp ypaR#pp ypa@#pp y(* UNIT Turtles zur Erzeugung von Turtlegraphik *) (* Copyright 1992 by Application Systems Heidelberg Software GmbH *) UNIT Turtles; (* ffentlicher Teil *) INTERFACE (* Konstanten *) CONST MaxX = 1000; (* maximale X-Koordinate *) MaxY = 1000; (* maximale Y-Koordinate *) MinPhi = 0; (* minimaler Winkel *) MaxPhi = 359; (* maximaler Winkel *) MaxWidth = 2 * MaxX; (* maximale Breite (-1) *) MaxHeight = 2 * MaxY; (* maximale Hhe (-1) *) TYPE CoordX = -MaxX..MaxX; (* Wertebereich horizontal *) CoordY = -MaxY..MaxY; (* Wertebereich vertikal *) Angel = MinPhi..MaxPhi; (* Wertebereich Winkel *) AngelRange = -MaxPhi..MaxPhi; (* erlaubte Winkelvernderung *) TurtleBase = OBJECT (* Basisobjekt Turtle *) X : CoordX; (* x-Koordinate *) Y : CoordY; (* y-Koordinate *) Phi : Angel; (* Winkel *) v_handle, (* VDI-Handle *) ScreenX, (* max. x-Koordinate *) ScreenY, (* max. y-Koordinate *) ColorBackground, (* Farbe Hintergrund *) ColorLine, (* Farbe Linie *) ColorTurtle : INTEGER; (* Farbe Turtle *) Visible, (* Turtle sichtbar? *) Paint, (* Turtle zeichnet? *) ErrorFlag, (* Fehler? *) WithDraw, (* Mit Draw? *) Shown : BOOLEAN; (* Turtle gezeichnet? *) (* Initialisieren *) CONSTRUCTOR Init; (* Abmelden *) DESTRUCTOR Done; (* Fehlerabfrage *) FUNCTION Error : BOOLEAN; (* Bildschirm lschen *) PROCEDURE Clear; (* Position und Ausrichtung setzen *) PROCEDURE Default(nx : CoordX; ny : CoordY; nw : Angel); (* Linienfarbe setzen *) PROCEDURE LineColor(c : INTEGER); (* Hintergrundfarbe setzen *) PROCEDURE BackgroundColor(c : INTEGER); (* Turtlefarbe setzen *) PROCEDURE TurtleColor(c : INTEGER); (* Linienfarbe ermitteln *) FUNCTION GetLineColor : INTEGER; (* Hintergrundfarbe ermitteln *) FUNCTION GetBackgroundColor : INTEGER; (* Turtlefarbe ermitteln *) FUNCTION GetTurtleColor : INTEGER; (* Turtle im positiven Sinne drehen *) PROCEDURE Turn(nw : AngelRange); (* Turtle bewegen *) PROCEDURE Go(amount : INTEGER); (* Stift anheben *) PROCEDURE PenUp; (* Stift senken *) PROCEDURE PenDown; (* Turtle zeigen *) PROCEDURE Show; (* Turtle verstecken *) PROCEDURE Hide; (* Turtle zeichnen *) PROCEDURE Draw(showit : BOOLEAN); END; Turtle = OBJECT(TurtleBase) (* normale Turtle *) (* Drehung nach links *) PROCEDURE Left(w : Angel); (* Drehung nach rechts *) PROCEDURE Right(w : Angel); (* Bewegung vorwrts *) PROCEDURE Forward(amount : INTEGER); (* Bewegung rckwrts *) PROCEDURE Backward(amount : INTEGER); END; TurtleGeom = OBJECT(Turtle) (* erweiterte Turtle *) (* Rechteck ausgeben *) PROCEDURE Rectangle(w, h : INTEGER); END; (* Implementation *) IMPLEMENTATION (* UNITs GEM und TOS importieren *) USES Gem, Tos; VAR Dummy : INTEGER; (* *** Methoden von TurtleBase *** *) CONSTRUCTOR TurtleBase.Init; VAR i : INTEGER; WorkIn : workin_array; WorkOut : workout_array; BEGIN (* Variablen vorbesetzen *) ErrorFlag := FALSE; ColorBackground := White; ColorLine := Black; ColorTurtle := Blue; Visible := TRUE; Paint := TRUE; Shown := FALSE; WithDraw := TRUE; (* virtuelle VDI-Workstation ffnen *) v_handle := graf_handle(Dummy, Dummy, Dummy, Dummy); FOR i:=1 TO 9 DO WorkIn[i] := 1; WorkIn[0] := 2 + Getrez; WorkIn[10] := 2; v_opnvwk(WorkIn, v_handle, WorkOut); IF v_handle = 0 THEN BEGIN ErrorFlag := TRUE; EXIT END; (* Bildschirmgre ermitteln *) ScreenX := WorkOut[0]; ScreenY := WorkOut[1]; (* Vorbereitung des Bildschirms *) Draw(TRUE); Clear; Default(0, 0, 90) END; DESTRUCTOR TurtleBase.Done; BEGIN Draw(FALSE); IF v_handle <> 0 THEN v_clsvwk(v_handle) END; PROCEDURE TurtleBase.Clear; VAR xy : ARRAY_4; BEGIN Draw(FALSE); v_clrwk(v_handle); Dummy := vswr_mode(v_handle, MD_REPLACE); Dummy := vsf_color(v_handle, ColorBackground); xy[0] := 0; xy[1] := 0; xy[2] := ScreenX; xy[3] := ScreenY; v_bar(v_handle, xy); Draw(TRUE) END; PROCEDURE TurtleBase.Default(nx : CoordX; ny : CoordY; nw : Angel); BEGIN Draw(FALSE); X := nx; Y := ny; Phi := nw; Draw(TRUE) END; PROCEDURE TurtleBase.LineColor(c : INTEGER); BEGIN ColorLine := c END; PROCEDURE TurtleBase.BackgroundColor(c : INTEGER); BEGIN ColorBackground := c END; PROCEDURE TurtleBase.TurtleColor(c : INTEGER); BEGIN ColorTurtle := c END; FUNCTION TurtleBase.GetLineColor : INTEGER; BEGIN GetLineColor := ColorLine END; FUNCTION TurtleBase.GetBackgroundColor : INTEGER; BEGIN GetBackgroundColor := ColorBackground END; FUNCTION TurtleBase.GetTurtleColor : INTEGER; BEGIN GetTurtleColor := ColorTurtle END; PROCEDURE TurtleBase.Turn(nw : AngelRange); BEGIN IF WithDraw THEN Draw(FALSE); Phi := (MaxPhi + 1 + Phi + nw) MOD (MaxPhi + 1); IF WithDraw THEN Draw(TRUE) END; PROCEDURE TurtleBase.Go(amount : INTEGER); VAR OldX : CoordX; OldY : CoordY; xy : ptsin_ARRAY; XNeu, YNeu : INTEGER; Argument : REAL; BEGIN IF WithDraw THEN Draw(FALSE); OldX := X; OldY := Y; (* neue Koordinaten in der richtigen Richtung *) Argument := (PI * Phi) / 180.0; XNeu := X + ROUND(amount * COS(Argument)); YNeu := Y + ROUND(amount * SIN(Argument)); (* Bildschirmgrenzen bercksichtigen *) IF ABS(XNeu) > MaxX THEN BEGIN IF XNeu < 0 THEN X := -MaxX ELSE X := MaxX END ELSE X := XNeu; IF ABS(YNeu) > MaxY THEN BEGIN IF YNeu < 0 THEN Y := -MaxY ELSE Y := MaxY END ELSE Y := YNeu; (* Ausgabe, wenn Flag gesetzt ist *) IF Paint THEN BEGIN Dummy := vsl_color(v_handle, GetLineColor); (* Die Koordinaten mssen umgerechnet werden! *) xy[0] := ROUND((LONGINT(OldX + MaxX) * LONGINT(ScreenX)) / LONGINT(MaxWidth)); xy[1] := ROUND((LONGINT(MaxHeight - OldY - MaxY) * LONGINT(ScreenY)) / LONGINT(MaxHeight)); xy[2] := ROUND((LONGINT(X + MaxX) * LONGINT(ScreenX)) / LONGINT(MaxWidth)); xy[3] := ROUND((LONGINT(MaxHeight - Y - MaxY) * LONGINT(ScreenY)) / LONGINT(MaxHeight)); v_pline(v_handle, 2, xy) END; IF WithDraw THEN Draw(TRUE) END; PROCEDURE TurtleBase.PenUp; BEGIN Paint := FALSE END; PROCEDURE TurtleBase.PenDown; BEGIN Paint := TRUE END; PROCEDURE TurtleBase.Show; BEGIN Visible := TRUE; Draw(TRUE) END; PROCEDURE TurtleBase.Hide; BEGIN Draw(FALSE); Visible := FALSE END; PROCEDURE TurtleBase.Draw(showit : BOOLEAN); CONST TurtleSize = 40; VAR OldColor : INTEGER; OldPaint : BOOLEAN; BEGIN IF Visible THEN BEGIN IF (NOT(Shown) AND showit) OR (Shown AND NOT(showit)) THEN BEGIN WithDraw := FALSE; OldPaint := Paint; Paint := TRUE; Shown := NOT(Shown); Dummy := vswr_mode(v_handle, MD_XOR); OldColor := GetLineColor; LineColor(ColorTurtle); Turn(150); Go(TurtleSize); Turn(120); Go(TurtleSize); Turn(120); Go(TurtleSize); Turn(-30); LineColor(OldColor); Dummy := vswr_mode(v_handle, MD_REPLACE); Paint := OldPaint; WithDraw := TRUE END END END; FUNCTION TurtleBase.Error : BOOLEAN; BEGIN Error := ErrorFlag; ErrorFlag := FALSE END; (* *** Methoden von Turtle *** *) PROCEDURE Turtle.Left(w : Angel); BEGIN Turn(w) END; PROCEDURE Turtle.Right(w : Angel); BEGIN Turn(-w) END; PROCEDURE Turtle.Forward(amount : INTEGER); BEGIN Go(amount) END; PROCEDURE Turtle.Backward(amount : INTEGER); BEGIN Go(-amount) END; (* *** Methoden von TurtleGeom *** *) PROCEDURE TurtleGeom.Rectangle(w, h : INTEGER); VAR HalfW, HalfH : INTEGER; BEGIN w := w - w MOD 2; h := h - h MOD 2; HalfW := w DIV 2; HalfH := h DIV 2; PenUp; Backward(HalfH); PenDown; Right(90); Forward(HalfW); Left(90); Forward(h); Left(90); Forward(w); Left(90); Forward(h); Left(90); Forward(HalfW); Left(90); PenUp; Forward(HalfH); PenDown END; END. f ANPANV * fANH`* gUfAN2B* $_NuNV/6.??? hrt@AN+\\O&N^Nu@m0Nu@n0NuNVH<*I(H.(&&n$n<. :. 02N802N:0G2nN40R0n2nN60SJRoJSnB@`pL='0') and (s[i]<='9') and (kommapos=0) then teil1:=teil1*10+ord(s[i])-48; if (s[i]='.') and (kommapos=0) then kommapos:=i; end; if kommapos<>0 then begin for i:=kommapos to length(s) do begin if (s[i]>='0') and (s[i]<='9') then begin stellen:=stellen+1; teil2:=teil2*10+ord(s[i])-48; end; end; end; for i:=1 to stellen do faktor:=faktor*10; teil2:=teil2/faktor; zahl:=teil1+teil2; hole_zahl:=zahl; end; begin a:=0.0; b:=0.0; c:=0.0; s1:=''; s2:=''; s3:=''; s4:='04'; rsrc_gaddr(R_TREE, form4, tree); SetPtext( tree, zahl1, s1); SetPtext( tree, zahl2, s2); SetPtext( tree, result, s3); SetPtext( tree, dezis, s4); repeat str(a:9,s1); str(b:9,s2); str(stellen:2,s4); wahl:=hndl_form(form4); if wahl=Rechne then begin stellen:=0; getptext(tree, zahl1, s1); getptext(tree, zahl2, s2); getptext(tree, dezis, s4); a:=hole_Zahl(s1); b:=hole_zahl(s2); stellen:=trunc(hole_zahl(s4)); if stellen>17 then stellen:=17; if stellen<0 then stellen:=0; if get_obj_state(tree, and_en)=selected then c:=(trunc(a) and trunc(b)) else if get_obj_state(tree, or_en)=selected then c:=(trunc(a) or trunc(b)) else if get_obj_state(tree, plus)=selected then c:=a+b else if get_obj_state(tree, minus)=selected then c:=a-b else if get_obj_state(tree, mal)=selected then c:=a*b else if get_obj_state(tree, geteilt)=selected then begin if b<>0 then c:=a/b else form_alert(1,'[1][ Division durch Null ][ OK ]'); end else if get_obj_state(tree, mod_en)=selected then begin if b<>0 then c:=trunc(a) mod trunc(b) else form_alert(1,'[1][ Division durch Null ][ OK ]'); end else if get_obj_state(tree, div_en)=selected then begin if b>0 then c:=trunc(a) div trunc(b) end; if ((c<2147483647.0) and (c=trunc(c))) then begin d:=trunc(c); str(d:19, s3); end else str(c:19:stellen, s3); if length(s3)<20 then setptext(tree,result,s3) else form_alert(1,'[1][ berlauf! | Zahl nicht darstellbar ][ OK ]'); end; until wahl=exit4; end; function SelectFile(titel : String) : String; var dir : DirStr; ext : ExtStr; name : NameStr; begin if GEM_pb.global[0] >= $0140 then fsel_exinput( path, f_name, button, titel ) else fsel_input( path, f_name, button ); if button = 0 then SelectFile := '' else begin FSplit( path, dir, name, ext ); SelectFile := dir + f_name; end; path:=dir+'*.*'; end; procedure datei_delete; begin error:=fdelete(f_name); if error<>0 then button:=form_alert(1,'[1][ Datei '+f_name+' | konnte nicht | gelscht werden ][ Pech ]') else button:=form_alert(1,'[1][ Datei '+f_name+' | wurde gelscht ][ Tja ]'); end; procedure folder_create; var dir : DirStr; ext : ExtStr; name : NameStr; ordner_name : String; begin FSplit( path, dir, name, ext ); ordner_name:=dir+f_name; error:=Dcreate(ordner_name); if error=0 then button:=form_alert(1,'[1][ Ordner | '+ordner_name+' | wurde angelegt ][ Gut so ]') else button:=form_alert(1,'[1][ Ordner | '+ordner_name+' | konnte nicht | angelegt werden ][ Nanu ]'); end; procedure umbenennen(oldname, newname : string); var dir : DirStr; ext : ExtStr; name : NameStr; file1, file2 : string; begin FSplit( path, dir, name, ext ); file1:=dir+oldname; file2:=dir+newname; error:=Frename(file1, file2); if error<>0 then button:=form_alert(1,'[1][ Datei '+oldname+' | konnte nicht in | '+newname+' umbenannt werden ][ Pech ]'); end; function ermittle_datei_uhrzeit(dt : DateTime) : string; var i, hour, minute, second : integer; dummystr, uhrzeit : string; begin str(dt.hour:2,uhrzeit); str(dt.min:2,dummystr); uhrzeit:=uhrzeit+':'+dummystr; str(dt.sec:2,dummystr); uhrzeit:=uhrzeit+':'+dummystr; for i:=1 to length(uhrzeit) do begin if uhrzeit[i]=' ' then uhrzeit[i]:='0'; end; ermittle_datei_uhrzeit:=uhrzeit; end; function ermittle_datei_datum(dt : DateTime) : string; var i, day, month, year : integer; dummystr, date : string; begin str(dt.day:2,date); str(dt.month:2,dummystr); date:=date+'.'+dummystr; str(dt.year:2,dummystr); date:=date+'.'+dummystr; for i:=1 to length(date) do begin if date[i]=' ' then date[i]:='0'; end; ermittle_datei_datum:=date; end; procedure datei_info; var F, attr, i : integer; time, dateilaenge : longint; DaTi : DateTime; t : Text; tree : pointer; lenstr : string; begin f_name2:=f_name; rsrc_gaddr(R_TREE, form2, tree); attr:=fattrib(Filename,0,0); (* Ermittle Dateiattribute *) attr:=(attr and 1); (* Schreibschutz aktiv ? *) F:=Fopen(Filename,FO_READ); if (F>=0) then begin dateilaenge:=Fseek(0,F,2); error:=Fclose(F); str(dateilaenge,lenStr); lenStr:=lenStr+' Bytes'; Assign(t,Filename); Reset(t); GetFTime(t,time); UnpackTime( time, DaTi ); SetPtext( tree, FNAME, f_name2); SetPtext( tree, F_DATE, ermittle_datei_datum(DaTi)); SetPtext( tree, F_TIME, ermittle_datei_uhrzeit(DaTi)); SetPtext( tree, F_LEN, lenStr); (* Falls Datei schreibgeschtzt, so invertiere das Feld "Nur Lesen" ansonsten das Feld Lesen/Schreiben *) if attr=0 then begin set_obj_state(tree, r_and_w, 1); set_obj_state(tree, only_r, 0) end else begin set_obj_state(tree, r_and_w, 0); set_obj_state(tree, only_r, 1); end; Hndl_Form( form2 ); (* Datei-Infobox aufrufen *) (* Ermittle den Dateinamen nach Verlassen der Box *) GetPtext( tree, FNAME, f_name2 ); for i:=1 to length(f_name2) do if f_name2[i]=' ' then f_name2[i]:='_'; if get_obj_state(tree, only_r)=selected then (* Fileattribut gendert? *) fattrib(Filename,1,1) else fattrib(Filename,1,0); if (f_name2<>f_name) and (length(f_name2)>0) then (* Dateiname gendert? *) umbenennen(f_name, f_name2); Close( t ); end else begin if F=-33 then form_alert(1,'[1][ Datei nicht gefunden ][ Pech ]') else form_alert(1,'[1][ Datei konnte nicht | geffnet werden ][ Pech ]') end; end; procedure hauptschleife; var wahl : integer; begin wind_update(beg_update); repeat wahl:=hndl_form(form1); case wahl of info: show_infobox; delete: begin f_name:=SelectFile('Lsche Datei'); if (button=1) and (f_name<>'') then datei_delete; end; f_create: begin Filename:=SelectFile('Ordner anlegen'); if (button=1) and (f_name<>'') then folder_create; end; calc: begin Rechner; end; d_info: begin Filename:=SelectFile('Datei-Info'); if (button=1) and (f_name<>'') then datei_info; end; freeram: begin freier_speicher; end; end; until wahl=exit1; wind_update(end_update); graf_mouse(ARROW, NIL); end; begin Filename:=''; path := FExpand( '' ) + '*.*'; { Aktuelles Verzeichnis } f_name := ''; ok:=false; stellen:=4; ap_id:=appl_init; if ap_id>=0 then begin graf_mouse(ARROW, NIL); error:=rsrc_load(Resourcefilename); if error=1 then ok:=true; if appflag and ok then begin (* als Programm gestartet *) hauptschleife; appl_exit; end else begin (* als Accessory gestartet *) menu_id := menu_register( ap_id, ' Disk-Jutility'); while menu_id>=0 do begin event_loop; if ok then hauptschleife; end; end; END; if not(appflag) then (* Endlosschleife, da Accessories nicht terminieren drfen *) WHILE TRUE DO event_loop; end. form_alert( 1, '[1][ Bye, Bye ][So isses]' ); maus(m_aus); schluss:=true; end; end; function ermittle_sondertasten : sondertasten; var status : INTEGER; BEGIN status:=Kbshift(-1); IF status>15 then status:=status-16; case status of 2 : ermittle_sondertasten:=lshift; 6 : ermittle_sondertasten:=lshift_ctrl; else ermittle_sondertasten:=keine_sondertaste; end; end; procedure geschafft; BEGIN Punkte[21]:=Punkte[21]+max_zeit-(clock-start_time) div 200; maus(m_an); form_alert(PROGRAM CKurve; USES Turtles; TYPE TurtleGraphik = OBJECT(Turtle) PROCEDURE CKurve(Grad, Seite : WORD); END; PROCEDURE TurtleGraphik.CKurve(Grad, Seite : WORD); BEGIN IF Grad = 0 THEN Forward(Seite) ELSE BEGIN DEC(Grad); SELF.CKurve(Grad, Seite); Left(90); SELF.CKurve(Grad, Seite); Right(90) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Default(250, -250, 0); MyTurtle.Hide; MyTurtle.CKurve(12, 12); MyTurtle.Show; MyTurtle.Done END END.#<%|E8y'TˍjTbrve >O>i}! ڐHyR) ܇t*C΅CP,rQJ9!>=Xԇ}HXsCqH}ԇ>?iC>?9]!Ɨ{~4(Jot'gCC|!rH#s!!ώeH}J?y\CB!`gл{.yy B!߅C !.$r$%0%]<]<]>#]?y ,rHX7ðЁPROGRAM Rechteck; USES Turtles; TYPE TurtleGraphik = OBJECT(TurtleGeom) PROCEDURE Quadrat(Seite : INTEGER); PROCEDURE Muster(Seite : INTEGER); END; PROCEDURE TurtleGraphik.Quadrat(Seite : INTEGER); BEGIN Rectangle(Seite, Seite) END; PROCEDURE TurtleGraphik.Muster(Seite : INTEGER); CONST DiffWinkel = 5; VAR i, iMax : INTEGER; BEGIN i := 0; iMax := 90 DIV DiffWinkel; REPEAT Quadrat(Seite); Left(DiffWinkel); INC(i) UNTIL i = iMax END; VAR MyTurtle : TurtleGraphik; Seite : INTEGER; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Hide; Seite := 1000; REPEAT MyTurtle.Muster(Seite); DEC(Seite, 100) UNTIL Seite = 0; MyTurtle.Show; MyTurtle.Done END END.&c rd3u|exSpLMU4D5E5EPCZѼ *B/5?oyRIi2aFhzL-Gэ- ůRV(ǻ,n^qqJqr.PjDjyמi>OϞig~O0e0?ژL?ǘ0~|E"jn_PROGRAM Sierpinski; USES Turtles; TYPE TurtleGraphik = OBJECT(Turtle) PROCEDURE Sierpinski(Grad, Seite : WORD); END; PROCEDURE TurtleGraphik.Sierpinski(Grad, Seite : WORD); VAR i : WORD; PROCEDURE Kern(Grad, Seite : WORD); VAR Seite2 : WORD; BEGIN IF Grad > 0 THEN BEGIN DEC(Grad); Seite2 := ROUND(Seite * SQRT(2.0)); Kern(Grad, Seite); Right(135); Forward(Seite); Left(45); Kern(Grad, Seite); Forward(Seite2); Left(180); Kern(Grad, Seite); Right(135); Forward(Seite); Left(45); Kern(Grad, Seite) END END; BEGIN FOR i:=1 TO 4 DO BEGIN Kern(Grad, Seite); Right(135); Forward(Seite); Left(45) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Default(-975, 975, 90); MyTurtle.Hide; MyTurtle.Sierpinski(6, 10); MyTurtle.Show; MyTurtle.Done END END.Ai{^x_Zu}zqjPK 0 THEN BEGIN SELF.Drachen(Grad - 1, Seite); Left(90); SELF.Drachen(1 - Grad, Seite) END ELSE BEGIN SELF.Drachen(-Grad - 1, Seite); Right(90); SELF.Drachen(Grad + 1, Seite) END END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Hide; MyTurtle.Drachen(13, 8); MyTurtle.Show; MyTurtle.Done END END.CBrWAU,pyA<1F38;7 0hW1<-Kτ>~D\tK?l.8\0yoYTD4'{z Cسޱ\e=н߽=Pzz=uzo\=nE+D2rêH`ȐC1"& -@  [57%*"! eǒT%0Rѕ$8"C"0 HQƔT0eP4Մ1Pppo.!@b]k!P8NPÐF1Ԯ$Sxn-4#PROGRAM Rekursiv; USES Turtles; TYPE TurtleGraphik = OBJECT(TurtleGeom) PROCEDURE Quadrat(Seite : INTEGER); PROCEDURE Rekursiv(Grad : WORD; Seite : INTEGER); END; PROCEDURE TurtleGraphik.Quadrat(Seite : INTEGER); BEGIN Rectangle(Seite, Seite) END; PROCEDURE TurtleGraphik.Rekursiv(Grad : WORD; Seite : INTEGER); BEGIN IF Grad > 0 THEN BEGIN Quadrat(Seite); SELF.Rekursiv(Grad - 1, Seite DIV 2) END END; VAR MyTurtle : TurtleGraphik; BEGIN MyTurtle.Init; IF NOT(MyTurtle.Error) THEN BEGIN MyTurtle.Hide; MyTurtle.Rekursiv(5, 1500); MyTurtle.Show; MyTurtle.Done END END.ƧXWۼ\|s;j稖LE&p#hLnB2M ,.->i2> >Nf_~*yarOw)sAYHοR%A ?vJ_R4c?B?b$.v{Z︆g!?ý07BPe oRqu[i|^~K}I}?}"uƉY\"(0 1$%QUeuh6\}D԰ڕbU5J+  .άfYƕak`FPROGRAM IfDef; BEGIN {$IFDEF DEMO} WRITELN('Dieses ist das Demo!'); {$ENDIF} WRITELN('Hello World.'); {$IFDEF DEMO} WRITELN('Das Ende des Demos.') {$ELSE} WRITELN('Das Ende.') {$ENDIF} END. 0 HAt+Y &nHrf$ #@1O/E4Í #|  )%tF$U3;IV;~o>9Cič/$tPf/t!\ܔ:wa+1H`pf;/A#T]~4lBH>@=`= iA֊2ͩDb,bl9E?ճZ"|@s>+mg}vZ0߸5$"i`P-hH 5A@Ne=l=8:bٲ4e FV{!"Sr F9w8HG}cVo4czH8LRm8RZ[if.3pz+& ,ppb"ٿ\Sdz Y"vN'y^2$$b\B=}⻿<]?<-[Ie ՛_T׀0"IvΘRZZmJ]o:0:DIAȩ0E,=79@@)߼  \b.eXoC**]('O,)ዙmK5.Er}uHFLjžϳ0<dzeƸM2xMp(puv~s~}tTtNsANH3&c{s(|_KcP#Yl|L+W("RbY&:p97?˯ r?>nZ')Y/W0m?҉ |T?KST]QPROGRAM IfNDef; {$DEFINE MyProgram} BEGIN {$IFNDEF YourProgram} WRITE('Hello '); {$ENDIF} WRITELN('World!') END.=Gʤ/(kLF-BgnN0[&v:[Q3۷뛸ԟ.B9!te#L_ ,d7LR[1ɣa6#%ғ)PW]OO:B~ =-m|PU=GLJ5Lv_ߕu{ިޘN}ta[{7C#p0$o}{kg]qV CJ:π<&;і~s?{n׻l6tQgw:+:$y8`Xr 2`=wkgX9<S*UOZfpowgئzuq8CBmbPqlm,uj6O]"k\lp^ю]h4C6r4d3=~OFXΌ'(av 0ݟ {_Nb8^SDd.߽j@r6bF4hYgOf6wVce+ደ čPs. 'R4$8nOhhcPؑA:? bU Ek/,M%*cWGG"^ #bȍ HFgz#̉ wzH,7? @dF8dD8j( ֈ8pCP%ky(W$c!@GzKqyA@m;U+`Lw#(9@Bc3gԌ9*%f⥖4``G ݂Dcik:e29LhdB ,0s#1!hmH3-'8<G'N(1F̶!Cs1(PROGRAM Define; {$DEFINE MySymbol} BEGIN {$IFDEF MySymbol} WRITELN('Hello World!'); {$ENDIF} {$UNDEF MySymbol} {$IFDEF MySymbol} WRITELN('Good Bye World!'); {$ENDIF} END. =|A:NQ62I8lSIkiNa3ML!FBˍ%An8^J\f Dr&`w;>" oԧ@}W>g{ВŐ* a9:}5PɎvDǨfs zϋp\F]Y3w䤶h^Bz[bގƨ՞6(+}! K#mσW>ƕas[@#uBU΋+E+lWWD)V S;Ku?8lckwo?2;?sζ5R7kr>_A$"*'+|>QiUxœu6*ĊXR@D[ U3GiMhy}D49J`ؔi&B*[.ХTWʚW:cE-2hMTBgġ!}>axE ֱSRK:vFY3d~X!GLo8N?MW  z] #osg圙]}zB |nƟ_{vt!F!O3J!8:I1U~͝:_z X+g3~CȤ?w&,>;'!m8=^YcJ}#-$i9:jI1e>E>Dh*L]NU̽Uqu8IzgA@ۗ@: W+V\QTDn og)wF/VM"( t,?ᎋ©pY#1$C2#m>پ*46Ce`H3˔%K_A: CtˤwXqq㸦F@"B;}b ytb5ˀ q[9v5)h;.[W{ cMҮ78Rr%m5 Nׇ(3\TA};v~mz;:2t'ݳD-%vt)q7dVq Dnlw=v2 `W [oyO^8ԡH1GM G/"cT~md=>8BϪ8('(l㩏5yk\D-qcEJ?Ua PRfs.)Wvslm O{( MӭBywo+<;ĸQ ;>ibl,5ДuZ_FެxV=sue‹? /ߩO]*ن3Gӱ?2Ϛ,@!ˇ2)NkRD7S[Wr34r HgchLmϼHX\#APROGRAM Fehler; (* Definition der Objekte *) (* Zwei hngt von Eins und Drei von Zwei ab *) TYPE Eins = OBJECT PROCEDURE ShowTypeName; PROCEDURE Meldung; END; Zwei = OBJECT(Eins) PROCEDURE ShowTypeName; END; Drei = OBJECT(Zwei) PROCEDURE ShowTypeName; END; (* Methoden Objekt Eins *) PROCEDURE Eins.ShowTypeName; BEGIN WRITELN('*** Nummer Eins ***') END; PROCEDURE Eins.Meldung; BEGIN ShowTypeName END; (* Methode Objekt Zwei *) PROCEDURE Zwei.ShowTypeName; BEGIN WRITELN('*** Nummer Zwei ***') END; (* Methode Objekt Drei *) PROCEDURE Drei.ShowTypeName; BEGIN WRITELN('*** Nummer Drei ***') END; (* Deklaration der Instanzen *) VAR One : Eins; Two : Zwei; Three : Drei; BEGIN One.Meldung; Two.Meldung; Three.Meldung END. ).iDaO[I7o?40vv,yߖr}v.7xU}3lzNl-| Q#g,vq Mdg|_ cc( ,y7iU6A,Hq/OuY@ׄ8{-p^–}9-OvӱƆr [}>Z[PROGRAM OopDemo1; (* Die Definition des Objekts ZAEHLER *) TYPE Zaehler = OBJECT N : INTEGER; PROCEDURE Init(NewN : INTEGER); PROCEDURE Up; PROCEDURE Down; PROCEDURE Show; END; PROCEDURE Zaehler.Init(NewN : INTEGER); BEGIN N := NewN END; PROCEDURE Zaehler.Up; BEGIN INC(N) END; PROCEDURE Zaehler.Down; BEGIN DEC(N) END; PROCEDURE Zaehler.Show; BEGIN WRITELN(N) END; (* Hier das eigentliche Programm - ohne Definition *) VAR MyInstance : Zaehler; BEGIN MyInstance.Init(0); MyInstance.Show; MyInstance.Up; MyInstance.Show; MyInstance.Down; MyInstance.Down; MyInstance.Show END.9 l<1c2%qSꄾJWoxMe?mѬ(?0Mmj7F Z6dzѵs*F\FXޖjEc3DTO*j9V.k @rZu4 $=z0Jdrm4һEAvC#vԜ88WeK5u.XBŌd;:3{¤˟N>TG,+ffǙ9&=]Obg9:J>Q}nQNE&>k|eA-~a׃ўYdd\ϞŜtQ}!zˊ/Zp}ZPROGRAM Korrekt; (* Definition der Objekte *) (* Zwei hngt von Eins und Drei von Zwei ab *) TYPE Eins = OBJECT CONSTRUCTOR Init; PROCEDURE ShowTypeName; VIRTUAL; PROCEDURE Meldung; END; Zwei = OBJECT(Eins) PROCEDURE ShowTypeName; VIRTUAL; END; Drei = OBJECT(Zwei) PROCEDURE ShowTypeName; VIRTUAL; END; (* Methoden Objekt Eins *) CONSTRUCTOR Eins.Init; BEGIN END; PROCEDURE Eins.ShowTypeName; BEGIN WRITELN('*** Nummer Eins ***') END; PROCEDURE Eins.Meldung; BEGIN ShowTypeName END; (* Methode Objekt Zwei *) PROCEDURE Zwei.ShowTypeName; BEGIN WRITELN('*** Nummer Zwei ***') END; (* Methode Objekt Drei *) PROCEDURE Drei.ShowTypeName; BEGIN WRITELN('*** Nummer Drei ***') END; (* Deklaration der Instanzen *) VAR One : Eins; Two : Zwei; Three : Drei; BEGIN One.Init; Two.Init; Three.Init; One.Meldung; Two.Meldung; Three.Meldung END. QвF; GSPAKlٰf[(j΂|)p̱'k]>2bint Add(int x, int y) { return(x + y); } LogDatei *) TYPE Status = (geoeffnet, geschlossen); LogDatei = OBJECT FileName : STRING; Datei : TEXT; DateiStatus : Status; CONSTRUCTOR Init; DESTRUCTOR Done; PROCEDURE Log(s : STRING); PROCEDURE Auf(s : STRING); PROCEDURE Zu; END; (* Konstruktor *) CONSTRUCTOR LogDatei.Init; BEGIN DateiStatus := geschlossen; FileName := '' END; (* Destruktor *) DESTRUCTOR LogDatei.Done; BEGIN IF DateiStatus = geoeffnet THEN CLOSE(Datei) END; (* Datensatz schreiben *) PROCEDURE LogDatei.Log(s : STRING); BEGIN IF DateiStatus = geoeffnet THEN WRITELN(Datei, s) END; (* Protokolldatei ffnen *) PROCEDURE LogDatei.Auf(s : STRING); BEGIN ASSIGN(Datei, s); REWRITE(Datei); DateiStatus := geoeffnet; WRITELN(Datei, 'Log-Datei'); WRITELN(Datei, '========='); WRITELN(Datei) END; (* Protokolldatei schlieen *) PROCEDURE LogDatei.Zu; BEGIN IF DateiStatus = geoeffPROGRAM OopDemo2; (* Die Definition des Objekts ZAEHLER *) TYPE Zaehler = OBJECT N : INTEGER; PROCEDURE Init(NewN : INTEGER); PROCEDURE Up; PROCEDURE Down; PROCEDURE Show; END; AbZaehler = OBJECT(Zaehler) PROCEDURE Click; END; AufZaehler = OBJECT(Zaehler) PROCEDURE Click; END; PROCEDURE Zaehler.Init(NewN : INTEGER); BEGIN N := NewN END; PROCEDURE Zaehler.Up; BEGIN INC(N) END; PROCEDURE Zaehler.Down; BEGIN DEC(N) END; PROCEDURE Zaehler.Show; BEGIN WRITELN(N) END; PROCEDURE AbZaehler.Click; BEGIN Up END; PROCEDURE AufZaehler.Click; BEGIN Down END; (* Hier das eigentliche Programm - ohne Definition *) VAR ZAb : AbZaehler; ZAuf : AufZaehler; BEGIN ZAb.Init(0); ZAuf.Init(0); ZAb.Click; ZAb.Show; ZAb.Click; ZAb.Show; ZAuf.Click; ZAuf.Show; ZAuf.Click; ZAuf.Show END.ے8CaȤGkfy*`W$ggW7nH؜.9SBYRWg-Mr5ٹ!=lPROGRAM DynObj; (* Definition des Objekts LogDatei *) TYPE Status = (geoeffnet, geschlossen); LogDatei = OBJECT FileName : STRING; Datei : TEXT; DateiStatus : Status; CONSTRUCTOR Init; DESTRUCTOR Done; PROCEDURE Log(s : STRING); PROCEDURE Auf(s : STRING); PROCEDURE Zu; END; (* Konstruktor *) CONSTRUCTOR LogDatei.Init; BEGIN DateiStatus := geschlossen; FileName := '' END; (* Destruktor *) DESTRUCTOR LogDatei.Done; BEGIN IF DateiStatus = geoeffnet THEN CLOSE(Datei) END; (* Datensatz schreiben *) PROCEDURE LogDatei.Log(s : STRING); BEGIN IF DateiStatus = geoeffnet THEN WRITELN(Datei, s) END; (* Protokolldatei ffnen *) PROCEDURE LogDatei.Auf(s : STRING); BEGIN ASSIGN(Datei, s); REWRITE(Datei); DateiStatus := geoeffnet; WRITELN(Datei, 'Log-Datei'); WRITELN(Datei, '========='); WRITELN(Datei) END; (* Protokolldatei schlieen *) PROCEDURE LogDatei.Zu; BEGIN IF DateiStatus = geoeffnet THEN BEGIN CLOSE(Datei); DateiStatus := geschlossen; END; END; (* Das eigentliche Programm *) VAR Log1, Log2 : ^LogDatei; BEGIN NEW(Log1, Init); NEW(Log2, Init); (* Protokoll mit Objekt 1 *) Log1^.Auf('LOGFILE1.TXT'); Log1^.Log('Hello World!'); Log1^.Zu; (* Protokoll mit Objekt 2 *) (* Datei wird erst mit Destruktor geschlossen *) Log2^.Auf('LOGFILE2.TXT'); Log2^.Log('Hello World!'); DISPOSE(Log2, Done); DISPOSE(Log1, Done) END. ||_X7Ѧ\x+M^? "\娒2aqPbFMM{w?{ima Wކ>\WX'ق#Q:E\/{Fg<,_iE!ƧywhVdKӷA_=2]cL^f'-R-2pG]ea&t%$ W|U޿&i ;o_e?eA݈wwg*f-<HG9agRwr}bkR1, $YͷEcGH$պdie0J_Ḣ>@\tط˳MM}uu5cVu|]eSKHOR?$orV=^iMŏV+%^D6{?Hg]}e˳eLW;2*^_)ԙ'?$d#yv?i\}skBUy;4'R{YIs p{Ѣ:IrcKPROGRAM CPas; {$L C} {$I C.INC} BEGIN WRITELN(Add(3, 5)) END.RDPW!3!FyVM lR:FUL͡@O9 y RMНFAJ2aP, ə^}S0awFp(_dT,pR |#?EۄgqwI622g _g5^ $\s03/]IbǞ)(>c+BgZ,8j3ҍqq0R0 h;9e%9!Y|ГPyڋ;cqphS0v^Ά4&7~^*:Q=qrEc(.TZ4q=HĸϘ/B!7,S(׈]=$/aP,\g*7d))2h.IH( (ϭrX7m`/T8Ŏiһ'eOz|Aa $0Ǯ @~AXu*Tϔ)0|]ޙ)&ftN<6fq?j(k֛ISkPlxN'xE#MٯkǪ ySKAi3۾rǁ<V[[G6mU)񧕶Y EvtMqvF;7Az 7 w㥠 6 ʿn@3xwjN#J3c;Y<D6H9IC?4zMI"խj n{N` 49 /|Mnj(UҦdj :塆I  [;rEvٰ#'<W۶/"z4EC;h$R$J*/4W\Ԩql +C5$Ke &[Imޠf4nJoY8޳_҅.raFUNCTION Add(x, y : INTEGER) : INTEGER; EXTERNAL; m.k]=x(*vgԶJm5\k>r ]M5}$uNw2#J@ 'Q o{Rw>jWunUWﵨ$ݒu0 Uրa37g ڛG8W0?jspG-Bd7L[g{>oApu3ۺ>w;\'zU-:SXZ o߯}^rS\%7|ʼnb04潞L M-"*2=6v|ȼ|\1vG_iCoi߂3 l鉱?N)m(j8:Nfpm|k'b o[?GlDsąD'Uotx&48ܽw؍}{ t/97R};b0g[ ^1n; I*OϬy4"=pވ@Ϣ@"N,~A rHD9hn{u@s !Ol VE*>T؆` N]'jGsXЄ!XE 7՞PH-K؃dOp_,Q$ yQ(88d C[ ^7kDzpOl $;BU)b e!ƤzV`ʏ-Y#´ڄ#@~9d9,rw( lN ANuAddǴq|+ˏwJ=Uww^-|x\I|[0E̢ a"XCs*ơ,߃]84Ƌ/fERYf ؆0$ fNdX4-UeXʸХ5ߌ=͕S\A-Pa(~NzUޤSŻY 2Ɠ:0ʷT he`WEpṬ'36?RL*A)fuzj},'ƪa^=-*MSq\v[> W}q}ĩ=5<OGCD?6w"f{xKCy&k:| [39q+VCv(C*_e BE#@T\u&ʁx19 &@ak2U;>~'c%8z5s z,L/2N7)#g-WUDtwc/ݬlR6P^<p*Zg6ُ + B-+^oܸ$p 3?{吼#DԔo^ݍu?'GP(뇽ur&&C0g G.xnQȤ}dPROGRAM ProgExample; USES UnitExample; BEGIN Hello END. ,Ǟq X9S-A55Θ0b[ g[M9:̞i/T."``D=hˑZl֦@㘼z,BKQӂK';]lG f͐Jkdfh4)V|a{hك6ʏ{1Pߓ9_/xWlK} d~d^Ie grՏn  F}3Y!6P>zǨ`BAU*,42Y)U]z]|)ٺͤ e\0@E3Tʳ>#ۦoWg# %T qTlMQܪY (GoE\PA })kj%/۵"⟠`\H,N[ɞ7 ~3:32l!qǦRc1ڟ&@$w3:&׼r5~ KUNIT UnitExample; INTERFACE PROCEDURE Hello; IMPLEMENTATION PROCEDURE Hello; BEGIN WRITELN('Hello World!') END; END.輀`~h L*O\^zLϨbVtU!Ys]As*DssU*nΓ0s-թV 1 :^O`U9jLҼ2L3sbjA~r G> Kb& I[P t*:@fQq2PSaR&$s,C8&jf"퇎Tp u!95ō&NTS#J.cLCyf݌4q~hNCd `0$JDN;HXlsK!a].!̠/RϭW 1<1HC+-rlT>zUޠ+u)ԁlSHQCb@S*<`$s+aҾ>5ƥ`>Cľl-@僩CRd_uY:&rVr8=nF_;m+*i(bGʱq5 B-W%(dM^g~Qn!IIhYw8Lr?Zq 0hVEEkm?0IY@JV6˙Gꬽf7 B^Ҥϟj[PY&"g6U9bFy\(\HnV)܍כH-IkfkfTqvjܵ`F(D$XoDhpgnXr;Kb%#ԎKB xؙ}-X*Z`^|Oc6Yi)UNIT Lesen; (* ffentlicher Teil *) INTERFACE CONST WortLaenge = 80; TYPE WortTyp = STRING[WortLaenge]; FUNCTION HoleNaechstes : WortTyp; (* nicht-ffentlicher Teil *) IMPLEMENTATION CONST DateiName = 'WORTE.TXT'; MaxSpruenge = 10; TYPE WortZeiger = ^WortListe; WortListe = RECORD Wort : WortTyp; Naechstes : WortZeiger END; VAR NaechstesWort : WortZeiger; OldProc : POINTER; (* ein Wort aus der Liste ermitteln *) FUNCTION HoleNaechstes : WortTyp; VAR Spruenge, i : 0..MaxSpruenge; Vorgaenger : WortZeiger; BEGIN (* Kein Wort in der Liste? *) IF NaechstesWort = NIL THEN HoleNaechstes := '' ELSE (* Noch Worte in der Liste! *) BEGIN (* Anzahl der Felder, die bersprungen werden *) Spruenge := RANDOM(MaxSpruenge); (* Felder berspringen *) FOR i:=1 TO Spruenge DO NaechstesWort := NaechstesWort^.Naechstes; (* Wort ermitteln *) HoleNaechstes := NaechstesWort^.Wort; (* War es das letzte Wort? *) IF NaechstesWort = NaechstesWort^.Naechstes THEN NaechstesWort := NIL ELSE BEGIN (* Vorgnger ermitteln *) Vorgaenger := NaechstesWort; WHILE Vorgaenger^.Naechstes <> NaechstesWort DO Vorgaenger := Vorgaenger^.Naechstes; Vorgaenger^.Naechstes := NaechstesWort^.Naechstes; DISPOSE(NaechstesWort); NaechstesWort := Vorgaenger^.Naechstes END END END; (* Worte aus Datei lesen und Liste aufbauen *) PROCEDURE WorteLesen; VAR Datei : Text; Wort : STRING; NeuesWort : WortZeiger; BEGIN ASSIGN(Datei, DateiName); RESET(Datei); (* Lesen, bis Datei leer ist *) IF IORESULT = 0 THEN BEGIN WHILE NOT(EOF(Datei)) DO BEGIN READLN(Datei, Wort); (* Wort nicht ber 80 Zeichen? *) IF (LENGTH(Wort) <= WortLaenge) AND (LENGTH(Wort) >= 1) THEN BEGIN NEW(NeuesWort); NeuesWort^.Wort := Wort; (* Wort in der Liste anhngen *) (* Das letzte Feld zeigt immer auf das erste! *) IF NaechstesWort = NIL THEN BEGIN NaechstesWort := NeuesWort; NaechstesWort^.Naechstes := NeuesWort END ELSE BEGIN NeuesWort^.Naechstes := NaechstesWort^.Naechstes; NaechstesWort^.Naechstes := NeuesWort; NaechstesWort := NeuesWort END END END; CLOSE(Datei) END END; (* Ggf. reservierter Speicher mu freigegeben werden! *) PROCEDURE ExitHandler; VAR AktWort, StartWort : WortZeiger; BEGIN IF NaechstesWort <> NIL THEN BEGIN StartWort := NaechstesWort; REPEAT AktWort := NaechstesWort; NaechstesWort := NaechstesWort^.Naechstes; DISPOSE(AktWort) UNTIL NaechstesWort = StartWort; END; EXITPROC := OldProc END; (* Initialisierung der Unit *) BEGIN NaechstesWort := NIL; RANDOMIZE; OldProc := EXITPROC; EXITPROC := @ExitHandler; WorteLesen END.Yﳍ#@6+bҕFS8|"QV1$[x!U3xq-YȷuNKzu̪ވ/DoJp!nƙ Kښ;o+PROGRAM WorteRaten; USES Lesen; VAR RateWort : WortTyp; KeineLustMehr : BOOLEAN; (* Das Spiel *) PROCEDURE Spiele(RateWort : WortTyp); VAR WortMaske, Eingabe : WortTyp; Beenden : BOOLEAN; i : 1..WortLaenge; (* Initialisierung *) PROCEDURE Init(VAR Maske : WortTyp; Wort : WortTyp); VAR i : 1..WortLaenge; BEGIN WRITELN('Rate das Wort! (*=Ende)'); Beenden := FALSE; Maske := ''; FOR i:=1 TO LENGTH(Wort) DO Maske := Maske + '.' END; BEGIN Init(WortMaske, RateWort); (* Bis ein Ende kommt... *) WHILE NOT(Beenden) DO BEGIN (* Maske ausgeben *) WRITELN('Bisher erraten: ', WortMaske); (* Neue Eingabe *) READLN(Eingabe); (* Ende gewnscht? *) IF Eingabe = '*' THEN BEGIN KeineLustMehr := TRUE; Beenden := TRUE END ELSE BEGIN (* Nur ein Zeichen eingegeben? *) IF LENGTH(Eingabe) = 1 THEN BEGIN (* Buchstabe in der Maske ersetzen *) FOR i:=1 TO LENGTH(RateWort) DO IF Eingabe[1] = RateWort[i] THEN WortMaske[i] := Eingabe[1]; (* Wort komplett? *) IF WortMaske = RateWort THEN BEGIN WRITELN('Das mte es nun sein!'); Beenden := TRUE END END ELSE BEGIN (* Wort richtig erraten? *) IF Eingabe = RateWort THEN BEGIN WRITELN('Richtig!'); Beenden := TRUE END ELSE WRITELN('Leider falsch.') END END END END; BEGIN KeineLustMehr := FALSE; (* Worte aus dem Datenbestand holen, bis keines mehr da ist! *) RateWort := HoleNaechstes; WHILE (RateWort <> '') AND NOT(KeineLustMehr) DO BEGIN Spiele(RateWort); RateWort := HoleNaechstes END END. h]P5V{\Y)Unʁ*ET2ֳ\q.?imۻYDX)-im4i1v NZ7z>Ž( G^iW[|G_3;M 8E4Pf4SxT@!Ƃ8XU.۲׎ID]6@JeȵK#XmB HgVlk~Ğ35 |='*v[S2֚xȣ=*rwX;ڿ!::0Y%>jaxWg#IRjgWy]8'COMPUTER ATARI PASCAL Ou`s]a|q!t=O7jdd{4ZϫR͘6a,!<氧WH9YW/׃,pabef|ϖ?L#[M{u^bbw.)x_[VC)t=!ՙoިiFtߞ1 .pV*B|fyUb:JE%QBA{^c`(A ?*~!̿Zb^ QC7՜H5)?=1YrțH:z' =˿@Ɉ"A0QwZn=z\1uM@&I#]ocr-im: zUP9f-+RMDYUѤ,cYҌ v~B>|b?(x^_]\*΂hXG`^t (|51a~3_f4`੔H4>n}X$M!_;n eܘA,Fas|K94K͎eq>e].b:ԯiה9(f:m\$؁qkFVvpeJ?ɚII)G&U$ 5nEF^} kY+h2~}W5J_װFߣыlb# $Xx!cG&W A9K!ը;ZTT鰺j^%*hL{_l!V̤ͯ\},i2݂D!4G4W}sqy\ 8ПcTj,Zkz^e3YJ0O*o ^U^RftҤ﮿ u}:! g)ͣo\&9AIb $2n_ v0-iY^dCG֨f.a@I]־ΰI}}2oML+ PROGRAM EinMalEins; TYPE EinsBisZehn = 1..10; VAR x : EinsBisZehn; y : INTEGER; FUNCTION Berechne(a, b : EinsBisZehn) : INTEGER; BEGIN Berechne := a * b END; BEGIN WRITELN('Das Einmaleins'); FOR x:=1 TO 10 DO BEGIN FOR y:=1 TO 10 DO BEGIN WRITELN(x, ' * ', y, ' = ', Berechne(x, y)) END END END. ^Z1.alė͜ $->5bh~N~9/{|Ws"5Zy+в.?~Fdfc2O$+^uşfܥoܣ7x>o2%<?(dxx% 0[)6FCjR];K,=5PN fa$\5 x0_}^&N -n, ao a~dZ< Wx!kt[-n^ I䍠1x)Ի br /*!l|o_+6)odF8{)d?ҏ`>d(E' YBrn#M{+B>~)Rf t@- OhK۷9-ۡZ΁+J!>u?z@dMYye A>ީH?tR VtpܧA6FoڀjQ A<ҌIy8ʆQ42Fbq}У% 'H/0V{\ gʣx 6w.-ԍkF)oZl) q3zc:wCj|3Xcl80CuCkDieses ist die erste Zeile, doch die zweite folgt sogleich. Dieses ist die dritte Zeile, doch die vierte folgt sogleich. V(W8Ebɸ˟5,Fs>b8\չ7Lf7_%巺99ʉk"R݃1cp3:9iC΋]VQP ǿ産.9f7/>#i{:ީCjvOy$NZ3|]mҹAʭp!L݁>YEO8Gk h{;/j:jMôt;q"CMr' Hj8/FgG54WR:VO= *9F5뒊M-N؃M0܍鋸{ d4|ֽ|S_Cٙ{td1F}ɋdϼ; L;ˬ+ѥTg fe;T ؓ1 JfG)k)̭IT3LU >~Kʘ7<`R ~Vʉn˕|p[wSX>R|w9 0_H/ ZAZ.!1&eG+T8o۳s6v }! 1 j;òÉilg}]>7Ux'aK#!̅]ҙYrjD"n~pXZ:۬f .!5m&e/5AI?|l +tۭOՙԚ1(ItA坩\af:XX%ڤ |F#| ZY;>OLXncR?IΕi۩ ]j#Ga-֩V'Rc=h5h}@MF65F5鑷εgFcHL'^yK Xx PROGRAM FORWARD; PROCEDURE Beispiel; FORWARD; PROCEDURE Ausgabe; BEGIN Beispiel END; PROCEDURE Beispiel; BEGIN WRITELN('Hello World!') END; BEGIN Ausgabe END. PWA mٛ^1XkYn{"߮T1C;aB]"6V8 4thWy0 WxnX;7U3{B8 VTωX~ݵ!%ܐlUk_Q_,dx|]-Lj*m W G qk"Y:t{#XVr`0S|(JoRΦ˕,4˝Tџȗ*rFUvqpgK".ڦ/.%PT aWn9nǮq!A<.uNUD'&Ϟd Vh***ʷGt~p|w|9/RrtcCdj%k"yN;ޕniLvjnq8-6%JƜ^{(~?PROGRAM Gedicht; PROCEDURE Titel; BEGIN WRITELN('Das Mammutprogramm'); WRITELN END; PROCEDURE Strophe1; BEGIN WRITELN('Wenns Samstag Nacht ist und der Mond'); WRITELN('das Rechenzentrum still bewohnt,'); WRITELN('dann schleicht vom Speicher heimlich klamm'); WRITELN(' das Mammutprogramm.'); WRITELN END; PROCEDURE Strophe2; BEGIN WRITELN('Es stopft die ganze CPU,'); WRITELN('Peripherie und Speicher zu...'); WRITELN('Und ruhig rechnet wie ein Lamm'); WRITELN(' das Mammutprogramm.'); WRITELN END; PROCEDURE Strophe3; BEGIN WRITELN('Der Op''rateur, sein bser Geist'); WRITELN('ist nmlich wochenends verreist.'); WRITELN('Wohl ihm! Bald stehts schon in der ZAMM'); WRITELN(' das Mammutprogramm.'); WRITELN END; BEGIN Titel; Strophe1; Strophe2; Strophe3 END. ڭ9眚ܯ-:Lyr2%]ƌC5mG˫@f ]̎SETAuAcV;gOhfP.uwϦ*qKjZz&nKr,Y^sOB_pg؊h/]S; Զ@_PROGRAM Gruesse; TYPE Wochentag = (Montag, Dienstag, Mittwoch, Donnerstag, Freitag, Samstag, Sonntag); PROCEDURE Gruss(x : Wochentag); BEGIN CASE x OF Montag : WRITELN('Montags fngt die Woche an!'); Dienstag : WRITELN('Stre am Dienstag.'); Mittwoch : WRITELN('Tief am Mittwoch.'); Donnerstag : WRITELN('Langer Donnerstag!'); Freitag : WRITELN('Freitag ist Freutag.'); Samstag : WRITELN('Samstag ist Wochenende.'); Sonntag : WRITELN('Sonntag fr die Familie.') END END; BEGIN Gruss(Montag); Gruss(Donnerstag) END. L| ,t0[jF̡e e+ov6ڥw+iPNKdu-x4oYFɅil^om0. {_*shZpR7M )S`b%M6R\+s>WzisQf8,G!L_C8mT]'cW4cxdI"Lԉ_cSLUr[ce-Q}&p*8sV)P)ݻA8p)<#wOGL?;]/1e0O. d1;9tp.6KE6iqfic>$O}!D[LĀKrGC(lH)m]QX"ju0Ⱦ5tQPROGRAM InOut; VAR datei : TEXT; PROCEDURE WriteFile(VAR f : TEXT); BEGIN REWRITE(f); IF IORESULT <> 0 THEN WRITELN('Auweia, ein Fehler!') ELSE BEGIN WRITELN(f, 'Dieses ist die erste Zeile,'); (* mal mit Zeilenumbruch *) WRITE(f, 'doch die zweite folgt sogleich.'); (* mal ohne Zeilenumbruch *) WRITELN(f); (* mal nur Zeilenumbruch *) CLOSE(f) END END; PROCEDURE AppendFile(VAR f : TEXT); BEGIN APPEND(f); IF IORESULT <> 0 THEN WRITELN('Auweia, ein Fehler!') ELSE BEGIN WRITELN(f, 'Dieses ist die dritte Zeile,'); (* mal mit Zeilenumbruch *) WRITE(f, 'doch die vierte folgt sogleich.'); (* mal ohne Zeilenumbruch *) WRITELN(f); (* mal nur Zeilenumbruch *) CLOSE(f) END END; PROCEDURE ReadFile(VAR f : TEXT); VAR s : STRING; BEGIN RESET(f); IF IORESULT <> 0 THEN WRITELN('Auweia, ein Fehler!') ELSE BEGIN WHILE NOT(EOF(f)) DO BEGIN READLN(f, s); WRITELN(s) END; CLOSE(f) END END; BEGIN ASSIGN(datei, 'MYFILE.TXT'); WriteFile(datei); ReadFile(datei); AppendFile(datei); ReadFile(datei) END. >:fJuyKtGZjyuG{b&+T; jcAt84=)qoD;4gFwGpJ:f:h"\v ٲ;ʀ5O~Z찕˄gZ'+tG&{M p0RxFDaǩ0vFq]y)z\P* k xiҲC"|,Q40Yl.O0 DՒ8ޥ|>%:(~8:9% I2lPh:&eFD QUx_A5rDibmOgCFW)52jDaA{.Cl8;?r)J2Ds gu"*|9AV!FQQ[p2}wsP(ǞFQ}HfefFJ9pڟ4(Lg K[?4n;/҄/k,lUCoDTterVa#p6VMǥ'DٛDǥŕ˼^k 7ȤpuFk|햌G_h~ZfkH"XTh(t\z8 DznLzD|YȞ8&;::,lȽY[3:ʵypAyάg'l1~.?VQէSHq)(gyFtk9:mϔBd0R~H ]Js¦VIOP5h0Ngϕ&\ l>,?ܤ\##tx ,Ct%p]\Ԯb0h~'PROGRAM HELLO; BEGIN WRITELN('Hello World!') END. me95bEwd @%B bGC<~ =ZS (ݺ=C{b mFޥ\~OyovkG+ϟn.w^?MLjLNCtw-<zs"ݍ0|N1/3~am(V t; kDY@6چވFdl #FvL#[r87|>~>|>4}cl>ߒM+~Y4}ޑ}UϦrm r" g\=O/Ra/ц/ {cŨG B#R9R/<P" ~HqHmwe%ܳ>~n=D/߀v?(KGң2M35^ۚWχjHט LύH%aHz€$O>}փtz>)76tIscWڟC6*CʥmNZڄt[Dm6x Bq c{Hdt#~~WGpZ"XȖQXS]_rĂAYWy6-iOGӭŭ~[|ؓMHj`!CiD Mokt?c}v&|+LET-?*v&j늯`JqN0Ĺ4R)(w?]M6cº:`϶Q=eCi]z#oq]aY7꟝ E6h!VWWo*z"r.Z&|CfyoYg,޿=;KB/ ڛnڜ/;a*v,wI~*$o*Xy;rΎӚ g{"nM+7+;µ턗mPROGRAM MySecondProgram; PROCEDURE MyMessage; BEGIN WRITELN('Hello World!') END; BEGIN MyMessage END. 60\ϔ.PI*vICGD MW[IHxO_NmEdoQ1}L) H \6ݵ+ťІ/RK#'2z<c\F}:Ԡ4Xʮ1C|Έi]ɽܴ0K`2Z/ʷLGEZ N]ۡGK[M>hvg%Ifɋ_OF0`nm 5 ܵݘ#oV5P6}d 9u>'pYHLqP61Ȩɗ4ō] t\xZRY^p()Y-rJcZ8ɧqϬj+h2mJc<_aGd-P#;u%2f+{5t8>]ȕ),/K|Egq]nS$5Fc[U~l@߻4-xi¦ƒkfЧbG)- чqQ<5܋erlcih-#Z7!FC <@)j|8l4Kd/ߞpY{`5mb۳h 2B"W5o~m}_!9p h­`uVLvPROGRAM ProcExit; PROCEDURE Proc; BEGIN WRITELN('Dieser Text erscheint.'); EXIT; WRITELN('Dieser nicht!') END; BEGIN WRITELN('Nun folgt der Aufruf der Prozedur!'); Proc; WRITELN('Hier geht es weiter.') END. {^R>}F#b#L`@tLz{N.\"߱1;BV2kXC.mL!|xZEi 1wkX7i74h`05oHjڲ|ٳ/)QzYL>hHFGz#BJFݺ{6}bib0?Ͷɯ1) D|j^mPiQWBm`߉_Aޖincax? D|0QףADNollX#rL-9l8)qYM;6p.  Z&,h?PROGRAM ProgExit; BEGIN WRITELN('Dieser Text erscheint.'); EXIT; WRITELN('Dieser nicht!') END. z2@l^'v ANfI uln  Tإ]?n:~1ʩJtk@nD[ ³jfߪZq,7mMʥq4,dMi`,z8tڥ`80ΝE#= rT#|=T9.QJ.$dI;LpأܪtOuLM[Xzۄ ۡ{m236PԐ4m|?VB8T{Ef&tR7H2/.!ux`#As"_}i*$qq! :H i0ᲓSXS]a\Lt,ۗnNzI8Bۮde1ҚBK2lHGK)&7mIwsvg~.]Ij?hgj%i̐O Tnn=zQ"On@1 5J܀7^8q;(3~a9-k 'EBӵ33} &-j@=WPޤ^3bIĩ;MAlPȮbDc~A㦑\̴-Z=:>'eP2v!dx tv(?G ԡu"Cm1X iZMdr}8{w^Xt/VSi˭9sZ-Uxր;uI>k>-h\ERS,q 1;C'9>m)f_O2 m/dvtwٲvu';mH9Yj5ʓ3+3*^Leϣv\& CW.Gۨ4tat?%x2G^642}3yhf:mD4;6;KnTK~7op_pQ'? >:}N8]E?] Sy~'-a1]L"ԅ!<=t9CdGg3 }@2_?.Nٻ<:⹖g}+{棣i{q} %-KF;T.q&Z7<ƶ9op ۞L9 裧mߔtϱ6:rwTi"'s?zjS]9p \=C_" l!0;y=cW^]oЂϣ_%<^/T#LSThLRMd5ރ(&OИzf#Tf.L5ްD@0 ӻ冝Ai I`gbsͦwgfzd._8E[3Q\>JN.'Ҵ돲ce̍8MuB+NA(rt`EtzSZ4bwr\lv?vyiRfI^|_o2sΚ*EXKSRsu8?KdpF{J:KT= Anfang THEN BEGIN WRITE(Lauf:5); INC(Anzahl); IF (Anzahl MOD ZahlenProZeile) = 0 THEN WRITELN END; END; WRITELN END; BEGIN Init; Zahl := 0; ZweierPotenz := 1; WHILE ZweierPotenz <= MaxZweierPotenz DO BEGIN EineTafel(ZweierPotenz); WRITE('Ist Deine Zahl dabei (J/N): '); REPEAT READLN(Antwort); Antwort := UPCASE(Antwort) UNTIL Antwort IN ['J', 'N']; IF Antwort = 'J' THEN INC(Zahl, ZweierPotenz); ZweierPotenz := 2 * ZweierPotenz END; WRITELN; WRITELN('*** Deine Zahl lautet ', Zahl); WRITELN; WRITELN('Drcke Taste...'); REPEAT UNTIL KEYPRESSED END.O; qd2vD>o(@`:o94[g!UwEIr~i3f8f1}.~HOcA2v=):;s4O`W?G*pVwME]6f{CnW+A鉮#'/w6ZL3}nޤ 7}ْQаYxiЦ!:<5a:KY@(cg3j:fa;RAWoʬ?]83}ùCF׀%?֚ WqڪaGHEz׿^bJ' ? 7~!16*qvD-ZFzQ [T+GIV1,GCe@GrUWea@i0zm'Xr:%˜,ܯ 5|w".rge=V0zfbӟ[Lx ]!nȻ36aweKgdOȗc؋2E[<22dQg;1Ku/ijdײaAּfed8iؠ8yM8w4ϞSPROGRAM Schleife2; VAR n : INTEGER; BEGIN n := 0; WHILE n <> 5 DO BEGIN WRITE(n, ' '); n := SUCC(n) END; WRITELN END. ,6&?l5#XI 3;ep+|1秓?a84s^ŚN*KZ:ث(s]2B綼.Usy.d2\9M5Kswq׀1虩:=fsHͺv|\LJp2Bʐ~);m~zz7hW?ń_&٫c,<^>2>ܯ "9Dv'iK{L;D?"ϼ˓Sk!85;tX5~t~-ü5h9Kn^{˛a}~nuPlud]zRo0 ׏׮} 90?gж-=k~z~.xlDP=,Xq_H:'o)$3iiO 6xLl:^}&3Tn_ޝם^v:yZ(x%oWEyI7Qfʿ߷ٳ>kݣoCCq\ΡW 2!ن~nu&Vugpeg6Gi-ںxh-*ہy^Nao@ۣax{/wu~K?|t}|LAӫ}nc;5So#NٱΡ}"'`c~~i?dKYlݒ  ȼ"?(a?>bݝsb3^K#@xccO2$_1[_7m?i?ٳ۟PROGRAM Wertetabellen; TYPE MyFunction = FUNCTION(x : INTEGER) : INTEGER; VAR FktVar : MyFunction; FUNCTION f(x : INTEGER) : INTEGER; BEGIN f := x END; FUNCTION g(x : INTEGER) : INTEGER; BEGIN g := x * x END; FUNCTION h(x : INTEGER) : INTEGER; BEGIN h := x * x * x END; PROCEDURE Tabelle(min, max : INTEGER; fkt : MyFunction); VAR x : INTEGER; BEGIN FOR x:=min TO max DO BEGIN WRITELN(x, ' ', fkt(x)) END END; BEGIN Tabelle(1, 10, f); Tabelle(2, 5, g); Tabelle(-4, 8, h); (* und einmal mit Variable *) FktVar := f; Tabelle(7,46, FktVar) END. rf~6d _ ˽h 7RinGcH ĝg3)Gٚ h&k=(0"Vn% j,c9كo]2v_n֡:?QfmD3B_V-4IfFFVV27d90ս `L h^pЬgzy[" n$1`Ca[4=l"Ɔ8C] dɕ? ϴ5]zIQqYkj Jj\=`<;ݓȮ=py_IK ]&[J.[7s/cq'\9>7\ɣr}*:A4lD޵᜙Bt}%0PROGRAM Zahlenraten; CONST Maximum = 100; Schluss = 0; TYPE RateBereich = 1..Maximum; VAR Zahl : Schluss..Maximum; GedachteZahl : RateBereich; AnzahlVersuche : 1..MAXINT; BereitsGenannt : SET OF RateBereich; PROCEDURE Init; BEGIN RANDOMIZE; GedachteZahl := RANDOM(Maximum) + 1; WRITELN('Ich habe mir eine Zahl zwischen 1 und ', Maximum, ' gedacht!'); WRITELN('Errate Sie!'); AnzahlVersuche := 1; BereitsGenannt := []; WRITELN END; PROCEDURE Spiel; BEGIN WRITE('***** Erster Versuch; welche Zahl: '); READLN(Zahl); WHILE NOT(Zahl in [GedachteZahl, Schluss]) DO BEGIN WRITELN; IF Zahl IN BereitsGenannt THEN WRITELN('Hoppsala, die Zahl ', Zahl, ' hast Du schon genannt!') ELSE BEGIN WRITE(Zahl, ' ist '); IF Zahl > GedachteZahl THEN WRITE('grer') ELSE WRITE('kleiner'); WRITELN(' als die gedachte Zahl.'); WRITELN; BereitsGenannt := BereitsGenannt + [Zahl]; AnzahlVersuche := AnzahlVersuche + 1 END; WRITELN('***** Der ', AnzahlVersuche, '. Versuch.'); WRITE('Welche Zahl: '); READLN(Zahl) END; WRITELN END; PROCEDURE Auswertung; BEGIN IF Zahl = GedachteZahl THEN WRITELN('>>> Geschafft! Die Zahl hast Du in ', AnzahlVersuche, ' Versuchen erraten!') ELSE WRITELN('Vorbei! Die Zahl ', GedachteZahl, ' wre es gewesen.') END; BEGIN Init; Spiel; Auswertung; WRITELN; WRITELN('Drcke Taste...'); REPEAT UNTIL KEYPRESSED END. |hF7F. J՞J߰,yaw[og;fJ Cd(ϬNOU E0e).:f 0Hz>lt0E:u) < ?L9{{/f{{hL2[qwu[rcWpɒ~įrk[ʏi]^Y3 ]S*eQܔ }FMw0l̦`7"1^MSʀ/7gIg UH?bsitpib`Xz8X} 1zs}FVSVN+.*WLt]zO2o^؈t1<Wm? yE+RQj$l"-NBIQt ;"\xZ y«y: .3 5%o >pz!-p Q(.@}k"郩*//oNLɅBPROGRAM HELLO; BEGIN WRITELN('Hello World!') END. ݑ2z4*^ Iwl{Q9f]EVo iXD!r|OnG{Zb:Z"gT go~tv6_?R!B[S8m6(uu,7 @}} n ,z}hS1w{+~:E`}͡i,prǒped{ėې_GNo- PQjÆdŠoOonizǚxewznb6V\%`J21̸uf@*-@Rc=ByZlgO$]!L!QcM>Br%*}NA ݒHOשȺa5WH7$kNo{][g+ಮ!@M)Ve?Bx&i_0]͸tDvRE%>Dr&ɡ&7Ȇ)(x|7}AE53 !~ c)ޱ+G zrُccq-w ε$7|}O̘(DABۯ)$/_ #}ВgX"pc=Rv&Pm:fOnk/L]2hR3cK^7OANcGЗ? 1=hFjd$'#a |v:Wck*1~F{Vs{/1?Փbl ꂎEѫ&"}J7TwwѻU061.F5Iǀ,V@PyqjT~,+8Fl wXj!-j'[\-lYLݳ UP:`PROGRAM Run_Error; BEGIN RunError(37); END. >4 AnV^E]awwҝ>Oܘvk}/wRjlF%wV#tv[&7=y(>%eE?BWRۻ7Ro.[U.Ur`y^y;^(_&<~E釞J+͗~<עzU; G ?tO@wy%2]}vuw7E>hDbwQik]+P=Zw0Ry q;,֐y5x {uE7=.yYƽ>7>:y&bԵDx5=S<~'%1:i:rIMu8tn7GG3kJVLkֺ'wtIFFmog3%Y%k~{?eF˝{ JǗ S&o#qbuMCyVY!%P;ᔪ(W) vu) EEbDkZ7Ҁ_fy8X3=)6X0`VZ6 |…,G1tQ^_I@N8XV%ZF!"'"q4~)L͹eO`x4fbU *T0-aXr3 :QE. 5#ÃRF-GF'2 D2s75HA]IRUc̗赾b=#NLL)[$GVJ]_VONwkHQ { ------------------------------------------------------------ } { UNIT APPLICATION } { (c) 1992 Pure Software GmbH } { } { the unit application provides an object that handles all the } { bureaucratics a gem program is confronted with, e.g. dis- } { patching gem specific event messages to receiver objects. } { ------------------------------------------------------------ } unit Application; interface uses Receiver; type TApplicationPtr = ^TApplication; TApplication = object doneFlag : boolean; name : String; constructor Init( appName : String ); destructor Done; procedure Run; end; var applicationPtr : TApplicationPtr; { ============================================================ } implementation {$X+} uses GemInit, Gem; var oldExitProc : Pointer; { ------------------------------------------------------------ } { the contructor TApplication.Init sets up the object fields. } { ------------------------------------------------------------ } constructor TApplication.Init( appName : String ); begin applicationPtr := @self; name := appName; doneFlag := false; if not appFlag then menu_register( GemInit.apID, ' ' + name ); end; { ------------------------------------------------------------ } { the procedure TApplication.Run dispatches incoming gem } { messages to the appropriate object. } { the inner procedure EatUpKeyStrokes erases type ahead. } { ------------------------------------------------------------ } procedure TApplication.Run; var event, dummy, keycode : Integer; pipe : ARRAY_8; procedure EatUpKeyStrokes; begin repeat event := evnt_multi( MU_KEYBD or MU_TIMER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, pipe, 0, 0, dummy, dummy, dummy, dummy, dummy, dummy ); until event = MU_TIMER; end; begin while not doneFlag or not appFlag do begin EatUpKeyStrokes; event := evnt_multi( MU_KEYBD or MU_MESAG, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, pipe, 0, 0, dummy, dummy, dummy, dummy, keycode, dummy ); if event = MU_MESAG then begin case pipe[0] of WM_CLOSED: receiverChain^.CloseMessage( pipe[3] ); WM_FULLED: receiverChain^.FullMessage( pipe[3] ); WM_HSLID: receiverChain^.HorizSliderMessage( pipe[3], pipe[4] ); WM_VSLID: receiverChain^.VertSliderMessage( pipe[3], pipe[4] ); WM_MOVED: receiverChain^.MoveMessage( pipe[3], pipe[4], pipe[5] ); WM_SIZED: receiverChain^.SizeMessage( pipe[3], pipe[6], pipe[7] ); WM_TOPPED, WM_NEWTOP: wind_set( pipe[3], WF_TOP, 0, 0, 0, 0 ); WM_ARROWED: begin case pipe[4] of WA_UPPAGE: receiverChain^.PageUpMessage( pipe[3] ); WA_DNPAGE: receiverChain^.PageDownMessage( pipe[3] ); WA_UPLINE: receiverChain^.LineUpMessage( pipe[3] ); WA_DNLINE: receiverChain^.LineDownMessage( pipe[3] ); WA_LFPAGE: receiverChain^.PageLeftMessage( pipe[3] ); WA_RTPAGE: receiverChain^.PageRightMessage( pipe[3] ); WA_LFLINE: receiverChain^.ColumnLeftMessage( pipe[3] ); WA_RTLINE: receiverChain^.ColumnRightMessage( pipe[3] ); end; end; WM_REDRAW: receiverChain^.RedrawMessage( pipe[3] ); MN_SELECTED: receiverChain^.MenuSelectedMessage( pipe[3], pipe[4] ); AC_OPEN: receiverChain^.AccessoryOpenMessage; AC_CLOSE: receiverChain^.AccessoryCloseMessage; end; end else if event = MU_KEYBD then receiverChain^.KeypressedMessage( keycode ); end; end; { ------------------------------------------------------------ } { the destructor TApplication.Done takes care of the clean } { termination of TApplication objects. Actually it is not } { needed here, but descendants may use it. } { ------------------------------------------------------------ } destructor TApplication.Done; begin end; { ------------------------------------------------------------ } { this is an exit procedure to shut down gem programs } { correctly. but first it restores older exit procedures. } { ------------------------------------------------------------ } procedure ExitGemProgram; begin exitProc := oldExitProc; ExitGem; end; { ------------------------------------------------------------ } { the unit initialization part initializies the gem and sets } { an exit procedure for the termination of gem programs. } { ------------------------------------------------------------ } begin if InitGem then begin oldExitProc := exitProc; exitProc := @ExitGemProgram; graf_mouse( ARROW, nil ); end else form_alert( 1, '[3][Initialization error.|Program aborted.][OK]' ); end. { ============================================================ } BROWSERMENUTREEMENUFILEOPENMENUFILEINFOMENUFILECLOSEMENUFILEQUITINFODIALOGIDFILENAMEIDFILESIZE IDFILEDATE IDFILETIME(* Resource Datei Indizes fr BROWSER *) CONST Browsermenutree = 0; (* Menuebaum *) Menufileopen = 16; (* STRING in Baum BROWSERMENUTREE *) Menufileinfo = 17; (* STRING in Baum BROWSERMENUTREE *) Menufileclose = 18; (* STRING in Baum BROWSERMENUTREE *) Menufilequit = 20; (* STRING in Baum BROWSERMENUTREE *) Infodialog = 1; (* Formular/Dialog *) Idfilename = 3; (* STRING in Baum INFODIALOG *) Idfilesize = 4; (* STRING in Baum INFODIALOG *) Idfiledate = 9; (* STRING in Baum INFODIALOG *) Idfiletime = 10; (* STRING in Baum INFODIALOG *) N,,,,,,$ ,$PP ,  9 P? R g |    &  ,4 7 D Q \b h n  {  Filebrowser File Pure Pascal Demo-------------------- Accessory #1 Accessory #2 Accessory #3 Accessory #4 Accessory #5 Accessory #6 Open... ^O Info... ^I Close ^U-------------- Quit ^QInfo...OKIDFILENA.EXTIDFILESIZE12File name:Size:Date:Time:IDFILEDATE12IDFILETIMEbrowserResources,,,,,,$ ,$PP ,  9 P? R g |    &  ,4 7 D Q \b h n  {  Filebrowser File Pure Pascal Demo-------------------- Accessory #1 Accessory #2 Accessory #3 Accessory #4 Accessory #5 Accessory #6 Open... ^O Info... ^I Close ^U-------------- Quit ^QInfo...OKIDFILENA.EXTIDFILESIZE12File name:Size:Date:Time:IDFILEDATE12IDFILETIME{ ------------------------------------------------------------ } { UNIT BROWSERWINDOWS } { (c) 1992 Pure Software GmbH } { } { the unit BROWSERWINDOWS implements windows that display the } { contents of a file. } { ------------------------------------------------------------ } {$R-} unit BrowserWindows; interface uses TextWindows; type CharArrayPtr = ^CharArray; CharArray = Array[0..0] of Char; Marker = record line : LongInt; pos : LongInt; end; TBrowserWindowPtr = ^TBrowserWindow; TBrowserWindow = object ( TTextWindow ) textBuffer : CharArrayPtr; textSize : LongInt; currentPosition : Marker; constructor Init; function Close : Boolean; virtual; procedure GotoPrevLine; procedure GotoNextLine; procedure AdjustPosition( line : LongInt ); function GetLineLength( line : LongInt ) : LongInt; function GetLine( line : LongInt ) : String; virtual; function GetLineCount : LongInt; function LoadText( path : String ) : Boolean; end; { ============================================================ } implementation uses Gem; {$X+} { ------------------------------------------------------------ } { ExpandTabs expands the tab-characters of str. a tab stop is } { set after each tabSize characters. } { ------------------------------------------------------------ } function ExpandTabs( str : String; tabSize : Integer ) : String; var buffer : String; i, j, newLen, insBlanks : Integer; begin newLen := 0; for i := 1 to Length( str ) do begin if str[i] <> #9 then begin Inc( newLen ); buffer[newLen] := str[i]; end else begin insBlanks := tabSize - ( newLen mod tabSize ); for j := 1 to insBlanks do begin Inc( newLen ); buffer[newLen] := ' '; end; end; end; buffer[0] := Char( newLen ); ExpandTabs := buffer; end; { ------------------------------------------------------------ } { the contructor TBrowserWindow.Init initializes the object } { fields. } { ------------------------------------------------------------ } constructor TBrowserWindow.Init; begin TTextWindow.Init; currentPosition.line := 0; currentPosition.pos := 0; textSize := 0; textBuffer := nil; end; { ------------------------------------------------------------ } { the method TBrowserWindow.Close first calls its ancestor. if } { it returns true the window was closed. then the text buffer } { must be freed and the object fields be reset. } { ------------------------------------------------------------ } function TBrowserWindow.Close : Boolean; begin if TTextWindow.Close then begin if textBuffer <> nil then begin FreeMem( textBuffer, textSize ); textBuffer := nil; end; currentPosition.line := 0; currentPosition.pos := 0; textSize := 0; Close := True; end else Close := False; end; { ------------------------------------------------------------ } { the method TBrowserWindow.GetLineCount counts the number of } { lines of the current file. } { ------------------------------------------------------------ } function TBrowserWindow.GetLineCount : LongInt; var lc, cc : LongInt; begin lc := 1; for cc := 1 to textSize do begin if textBuffer^[cc] = #13 then Inc( lc ); end; GetLineCount := lc; end; { ------------------------------------------------------------ } { the method TBrowserWindow.GotoNextLine places the marker } { currentPosition onto the start of the next line. the marker } { is used to extract the text of a line. } { ------------------------------------------------------------ } procedure TBrowserWindow.GotoNextLine; var p : LongInt; begin if currentPosition.line < lineCount then begin Inc( currentPosition.line ); p := currentPosition.pos; while ( p < textSize ) and ( textBuffer^[p] <> #13 ) do Inc( p ); if p < textSize then begin Inc( p ); if ( p < textSize ) and ( textBuffer^[p] = #10 ) then Inc( p ); end; currentPosition.pos := p; end; end; { ------------------------------------------------------------ } { the method TBrowserWindow.GotoPrevLine places the marker } { currentPosition onto the start of the previous line. the } { marker is used to extract the text of a line. } { ------------------------------------------------------------ } procedure TBrowserWindow.GotoPrevLine; var p : LongInt; begin if currentPosition.line > 0 then begin Dec( currentPosition.line ); p := currentPosition.pos; Dec( p ); if ( p > 0 ) and ( textBuffer^[p] = #10 ) then Dec( p ); while ( p > 0 ) and ( textBuffer^[p-1] <> #13 ) and ( textBuffer^[p-1] <> #10 ) do Dec( p ); currentPosition.pos := p; end; end; { ------------------------------------------------------------ } { the method TBrowserWindow.AdjustPosition takes care that the } { marker currentPosition is placed onto line. the marker is } { used to extract the text of a line. } { ------------------------------------------------------------ } procedure TBrowserWindow.AdjustPosition( line : LongInt ); begin while currentPosition.line < line do GotoNextLine; while currentPosition.line > line do GotoPrevLine; end; { ------------------------------------------------------------ } { TBrowserWindow.GetLineLength determines the length of line. } { ------------------------------------------------------------ } function TBrowserWindow.GetLineLength( line : LongInt ) : LongInt; var pos : LongInt; begin AdjustPosition( line ); pos := currentPosition.pos; while ( pos < textSize ) and ( textBuffer^[pos] <> #13 ) do Inc( pos ); GetLineLength := pos - currentPosition.pos; end; { ------------------------------------------------------------ } { TBrowserWindow.GetLine extracts the text of line using the } { marker currentPosition. } { ------------------------------------------------------------ } function TBrowserWindow.GetLine( line : LongInt ) : String; var resString : String; len : LongInt; i : Integer; begin len := GetLineLength( line ); if len > 255 then len := 255; resString[0] := Char( len ); for i := 1 to Integer( len ) do resString[i] := textBuffer^[currentPosition.pos+i-1]; GetLine := ExpandTabs( resString, 4 ); end; { ------------------------------------------------------------ } { TBrowserWindow.LoadText loads the file path into a buffer. } { ------------------------------------------------------------ } function TBrowserWindow.LoadText( path : String ) : Boolean; var f : File; result : LongInt; begin {$I-} Assign( f, path ); Reset( f, 1 ); if IOResult <> 0 then LoadText := False else begin textSize := FileSize( f ); if textSize > 0 then begin GetMem( textBuffer, textSize ); if textBuffer = nil then LoadText := False else begin BlockRead( f, textBuffer^, textSize, result ); if result <> textSize then begin FreeMem( textBuffer, textSize ); LoadText := False; end else begin SetName( path ); lineCount := GetLineCount; vertTotal := lineCount; currentPosition.line := 0; currentPosition.pos := 0; LoadText := True; end; end; end else LoadText := False; end; {$I+} end; { ------------------------------------------------------------ } { because we are using dynamic memory allocation and we don't } { want to abort the program with a runtime error if we are } { running out of memory, the initialization part of the unit } { installs a user defined error handler. } { the return value 1 signals to continue the program and let } { New and GetMem return a nil pointer. } { ------------------------------------------------------------ } function HeapErrorHandler( size : LongInt ) : Integer; begin form_alert( 1, '[3][Out of memory!][OK]' ); HeapErrorHandler := 1; end; begin HeapError := @HeapErrorHandler; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT DIALOG } { (c) 1992 Pure Software GmbH } { } { the unit DIALOG provides some basic routines to handle } { dialogs. } { ------------------------------------------------------------ } unit Dialog; interface uses Resources; procedure DialogSetString( tree : TResource; index : Integer; str : String ); procedure DialogSetText( tree : TResource; index : Integer; str : String ); function DialogGetText( tree : TResource; index : Integer ) : String; function DialogExecute( tree : TResource ) : Integer; { ============================================================ } implementation uses Gem; {$X+} { ------------------------------------------------------------ } { the procedure DialogSetString copies str into the object } { index of tree. the object must be of the type G_STRING or } { G_TITLE and the length of the string in the resource file } { must be greater or equal the length of str. } { ------------------------------------------------------------ } procedure DialogSetString( tree : TResource; index : Integer; str : String ); begin SetFreeString( tree, index, str ); end; { ------------------------------------------------------------ } { the procedure DialogSetText copies str into the object } { index of tree. the object must be of the type G_TEXT, } { G_BOXTEXT, G_FTEXT or G_FBOXTEXT and the length of the } { string in the resource file must be greater or equal the } { length of str. } { ------------------------------------------------------------ } procedure DialogSetText( tree : TResource; index : Integer; str : String ); begin SetPtext( tree, index, str ); end; { ------------------------------------------------------------ } { the function DialogGetText returns the text of the object } { index of tree. the object must be of the type G_TEXT, } { G_BOXTEXT, G_FTEXT or G_FBOXTEXT. } { ------------------------------------------------------------ } function DialogGetText( tree : TResource; index : Integer ) : String; var resStr : String; begin GetPtext( tree, index, resStr ); DialogGetText := resStr; end; { ------------------------------------------------------------ } { the function DialogExecute executes the dialog described by } { tree. that means it shows the dialog box, handles input and } { finally hides the dialog box. the index of the exit button } { will be returned. } { ------------------------------------------------------------ } function DialogExecute( tree : TResource ) : Integer; var cx, cy, cw, ch : Integer; exitButton : Integer; begin form_center( tree, cx, cy, cw, ch ); form_dial( FMD_START, 0, 0, 0, 0, cx, cy, cw, ch ); objc_draw( tree, 0, MAX_DEPTH, cx, cy, cw, ch ); exitButton := form_do( tree, 0 ); form_dial( FMD_FINISH, 0, 0, 0, 0, cx, cy, cw, ch ); tree^[exitButton].ob_state := tree^[exitButton].ob_state and not SELECTED; DialogExecute := exitButton; end; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT FILES } { (c) 1992 Pure Software GmbH } { } { the unit FILES provides some basic file operations like } { executing a file selector and inquiring file parameters. } { ------------------------------------------------------------ } unit Files; interface function SelectFile : String; function GetFilename( path : String ) : String; function GetFilesize( path : String ) : String; function GetFiledate( path : String ) : String; function GetFiletime( path : String ) : String; { ============================================================ } implementation uses Dos, Gem, Tos; {$X+,V-} { ------------------------------------------------------------ } { the function SelectFile executes a file selector. the result } { string is the path of the selected file or an empty string. } { ------------------------------------------------------------ } function SelectFile : String; var dir, path, filename : DirStr; name : NameStr; ext : ExtStr; exitButton : Integer; begin Dgetpath( path, 0 ); path := FExpand( path ) + '\*.*'; filename := ''; fsel_input( path, filename, exitButton ); if exitButton = 0 then SelectFile := '' else begin FSplit( path, dir, name, ext ); SelectFile := dir + filename; end; end; { ------------------------------------------------------------ } { the function GetFilename separates the file name out of the } { path. } { ------------------------------------------------------------ } function GetFilename( path : String ) : String; var dir : DirStr; name : NameStr; ext : ExtStr; begin FSplit( path, dir, name, ext ); GetFilename := name + ext; end; { ------------------------------------------------------------ } { the function GetFilesize returns the size of the file } { specified by path as a string. } { ------------------------------------------------------------ } function GetFilesize( path : String ) : String; var fileRec : SearchRec; s : String; begin Findfirst( path, AnyFile, fileRec ); if DosError <> 0 then GetFilesize := '' else begin str( fileRec.size, s ); GetFilesize := s; end; end; { ------------------------------------------------------------ } { the function GetFiledate returns the date stamp of the file } { specified by path as a string. } { ------------------------------------------------------------ } function GetFiledate( path : String ) : String; var fileRec : SearchRec; ys, ms, ds : String[6]; dt : DateTime; begin Findfirst( path, AnyFile, fileRec ); if DosError <> 0 then GetFiledate := '' else begin UnpackTime( fileRec.time, dt ); str( dt.year, ys ); str( dt.month, ms ); str( dt.day, ds ); GetFiledate := ds + '.' + ms + '.' + ys; end; end; { ------------------------------------------------------------ } { the function GetFiletime returns the time stamp of the file } { specified by path as a string. } { ------------------------------------------------------------ } function GetFiletime( path : String ) : String; var fileRec : SearchRec; hs, ms : String[4]; dt : DateTime; begin Findfirst( path, AnyFile, fileRec ); if DosError <> 0 then GetFiletime := '' else begin UnpackTime( fileRec.time, dt ); str( dt.hour, hs ); str( dt.min, ms ); GetFiletime := hs + ':' + ms; end; end; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT GEMINIT } { (c) 1992 Pure Software GmbH } { } { the unit GemInit performs all init and exit stuff needed to } { execute a gem program. } { ------------------------------------------------------------ } unit GemInit; interface {$X+} uses gem; var vdiHandle, aesHandle : Integer; apID : Integer; workIn : workin_ARRAY; workOut : workout_ARRAY; charWidth, charHeight : Integer; boxWidth, boxHeight : Integer; function InitGem : Boolean; procedure ExitGem; implementation { ------------------------------------------------------------ } { this procedure ends up a gem program. } { ------------------------------------------------------------ } procedure ExitGem; begin v_clsvwk( vdiHandle ); appl_exit; end; { ------------------------------------------------------------ } { this function initalizes the gem. it returns true if it was } { successful. } { ------------------------------------------------------------ } function InitGem : Boolean; var i : Integer; begin apID := appl_init; if apID >= 0 then begin aesHandle := graf_handle( charWidth, charHeight, boxWidth, boxHeight ); workIn[0] := aesHandle; for i := 1 to workin_max - 1 do workIn[i] := 1; workIn[10] := 2; v_opnvwk( workIn, vdiHandle, workOut ); if vdiHandle <= 0 then begin appl_exit; InitGem := False; end else InitGem := True; end else InitGem := False; end; end. { ============================================================ } { ------------------------------------------------------------ } { PROGRAM FILEBROWSER } { (c) 1992 Pure Software GmbH. } { } { this program demonstrates how to build gem applications } { using object oriented pure pascal. } { the program implements a file browser. it shows how deal } { with more than one window, handle shortcuts for menu } { entries, do dialogs, write accessories, etc. } { ------------------------------------------------------------ } {$X+} program FileBrowser; uses Application, BrowserWindows, Menu, Dialog, Resources, Files, Gem; const maxBrowsers = 4; {$I BROWSER.I } type TBrowserMenu = object ( TMenu ) procedure MenuHandleItem( item : Integer ); virtual; procedure KeyPressed( keycode : Integer ); virtual; procedure AccessoryOpenMessage; virtual; procedure AccessoryCloseMessage; virtual; end; TBrowserApplication = object ( TApplication ) browserList : Array[1..maxBrowsers] of TBrowserWindow; browserAvail : Array[1..maxBrowsers] of Boolean; browserMenu : TBrowserMenu; resourcePool : TResourcePoolPtr; constructor Init; destructor Done; function GetAvailableBrowser : Integer; function GetTopBrowser : Integer; procedure BrowserOpen; procedure BrowserInfo; procedure BrowserClose; end; var browserApplication : TBrowserApplication; { ------------------------------------------------------------ } { this is the external start address of the resource file. } { resource file was converted into an object file using the } { utility BINOBJ, so it can be linked to the program. } { BINOBJ was invoked with the commandline } { browser.rsc browser.o browserResources } { ------------------------------------------------------------ } procedure browserResources; external; {$L BROWSER } { ------------------------------------------------------------ } { the method TBrowserMenu.MenuHandleItem switches over the } { menu items and executes the corresponding action. } { ------------------------------------------------------------ } procedure TBrowserMenu.MenuHandleItem( item : Integer ); begin case item of Menufileopen: browserApplication.BrowserOpen; Menufileclose: browserApplication.BrowserClose; Menufileinfo: browserApplication.BrowserInfo; Menufilequit: browserApplication.doneFlag := true; end; end; { ------------------------------------------------------------ } { the method TBrowserMenu.KeyPressed handles shortcuts for } { menu items. } { ------------------------------------------------------------ } procedure TBrowserMenu.KeyPressed( keycode : Integer ); begin case keycode of Ctrl_I: browserApplication.BrowserInfo; Ctrl_O: browserApplication.BrowserOpen; Ctrl_Q: browserApplication.doneFlag := true; Ctrl_U: browserApplication.BrowserClose; else TReceiver.KeyPressedMessage( keycode ); end; end; { ------------------------------------------------------------ } { if the program runs as an accessory the method } { TBrowserMenu.AccessoryOpenMessage is called when you click } { the menu item of the accessory in the accessory menu. } { ------------------------------------------------------------ } procedure TBrowserMenu.AccessoryOpenMessage; begin browserApplication.BrowserOpen; end; { ------------------------------------------------------------ } { if the program runs as an accessory the method } { TBrowserMenu.AccessoryCloseMessage is called when a main } { program is finished. } { ------------------------------------------------------------ } procedure TBrowserMenu.AccessoryCloseMessage; var i : Integer; begin for i := 1 to maxBrowsers do begin browserApplication.browserList[i].Close; browserApplication.browserAvail[i] := true; end; end; { ------------------------------------------------------------ } { the constructor TBrowserApplication.Init initializes the } { ancestor application object, the linked-in resource file, } { the menu and the browser windows. } { ------------------------------------------------------------ } constructor TBrowserApplication.Init; var i : Integer; rs : TResource; begin TApplication.Init( 'File browser' ); resourcePool := InitResourcePool( @BrowserResources ); rs := GetResource( resourcePool, Browsermenutree ); browserMenu.Init( rs ); for i := 1 to maxBrowsers do begin browserList[i].Init; browserAvail[i] := true; end; end; { ------------------------------------------------------------ } { the destructor TBrowserApplication.Done initiates the } { cleanups for the menu, the linked-in resource file and the } { browser windows, as well as calling the destructor of the } { ancestor. } { ------------------------------------------------------------ } destructor TBrowserApplication.Done; var i : Integer; begin browserMenu.Done; FreeResourcePool( resourcePool ); for i := 1 to maxBrowsers do begin browserList[i].Done; browserAvail[i] := true; end; TApplication.Done; end; { ------------------------------------------------------------ } { the methode TBrowserApplication.GetAvailableBrowser returns } { the index of an unused window in the browser window list or } { 0 if no more browsers are available. } { ------------------------------------------------------------ } function TBrowserApplication.GetAvailableBrowser : Integer; var i : Integer; begin GetAvailableBrowser := 0; for i := 1 to maxBrowsers do begin if browserAvail[i] then begin GetAvailableBrowser := i; Exit; end; end; end; { ------------------------------------------------------------ } { the methode TBrowserApplication.GetTopBrowser returns the } { index of the topmost browser window or 0 if no browsers are } { opened. } { ------------------------------------------------------------ } function TBrowserApplication.GetTopBrowser : Integer; var i : Integer; begin GetTopBrowser := 0; for i := 1 to maxBrowsers do begin if ( browserList[i].winHandle >= 0 ) and browserList[i].IsTop then begin GetTopBrowser := i; Exit; end; end; end; { ------------------------------------------------------------ } { TBrowserApplication.BrowserOpen opens a new browser if there } { is one available. it first opens a file selector to choose a } { file. if a file is selected a browser window will be opened. } { ------------------------------------------------------------ } procedure TBrowserApplication.BrowserOpen; var index : Integer; path : String; begin index := GetAvailableBrowser; if index > 0 then begin path := SelectFile; if Length( path ) > 0 then begin if browserList[index].LoadText( path ) and browserList[index].Open( 20 * index, 40 * index, browserList[index].fullFrame.w - maxBrowsers * 30, browserList[index].fullFrame.h - maxBrowsers * 50 ) then begin browserAvail[index] := false; end; end; end; end; { ------------------------------------------------------------ } { the method TBrowserApplication.BrowserInfo displays a dialog } { box showing informations about the topmost browser window. } { ------------------------------------------------------------ } procedure TBrowserApplication.BrowserInfo; var nameStr : String; tree : TResource; index : Integer; begin index := GetTopBrowser; if index > 0 then begin tree := GetResource( resourcePool, InfoDialog ); nameStr := browserList[index].GetName; DialogSetString( tree, IdFilename, GetFilename( nameStr )); DialogSetString( tree, IdFilesize, GetFilesize( nameStr )); DialogSetString( tree, IdFiledate, GetFiledate( nameStr )); DialogSetString( tree, IdFiletime, GetFiletime( nameStr )); DialogExecute( tree ); end; end; { ------------------------------------------------------------ } { the method TBrowserApplication.BrowserClose closes the } { topmost browser window. } { ------------------------------------------------------------ } procedure TBrowserApplication.BrowserClose; var index : Integer; begin index := GetTopBrowser; if index > 0 then begin browserList[index].Close; browserAvail[index] := true; end; end; { ------------------------------------------------------------ } { the body of the program first intializes all program } { parameters and then calls the run method that performs a } { loop that dispatches the occuring events. Finally it } { initiates necessary cleanups. } { ------------------------------------------------------------ } begin browserApplication.Init; browserApplication.Run; browserApplication.Done; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT RECEIVER } { (c) 1992 Pure Software GmbH } { } { the unit receiver provides a mechanism to distribute arisen } { events. } { the concept is to build a chain of receivers. if an event } { arises the message will be given to the first receiver in } { the chain. the receiver absorbes the message if it is for it } { or passes it to the next receiver. } { ------------------------------------------------------------ } unit Receiver; interface type TReceiverPtr = ^TReceiver; TReceiver = object nextReceiver : TReceiverPtr; constructor Init; destructor Done; procedure RedrawMessage( handle : Integer ); virtual; procedure CloseMessage( handle : Integer ); virtual; procedure MoveMessage( handle, x, y : Integer ); virtual; procedure SizeMessage( handle, w, h : Integer ); virtual; procedure FullMessage( handle : Integer ); virtual; procedure LineUpMessage( handle : Integer ); virtual; procedure LineDownMessage( handle : Integer ); virtual; procedure PageUpMessage( handle : Integer ); virtual; procedure PageDownMessage( handle : Integer ); virtual; procedure PageLeftMessage( handle : Integer ); virtual; procedure PageRightMessage( handle : Integer ); virtual; procedure ColumnLeftMessage( handle : Integer ); virtual; procedure ColumnRightMessage( handle : Integer ); virtual; procedure HorizSliderMessage( handle, relPos : Integer ); virtual; procedure VertSliderMessage( handle, relPos : Integer ); virtual; procedure KeyPressedMessage( keycode : Integer ); virtual; procedure MenuSelectedMessage( title, item : Integer ); virtual; procedure AccessoryOpenMessage; virtual; procedure AccessoryCloseMessage; virtual; end; var receiverChain : TReceiverPtr; { ============================================================ } implementation {$X+} { ------------------------------------------------------------ } { the contructor enters the receiver into the receiver chain } { so that it will get messages by the application. } { ------------------------------------------------------------ } constructor TReceiver.Init; begin self.nextReceiver := receiverChain; receiverChain := @self; end; { ------------------------------------------------------------ } { the destructor removes the receiver from the receiver chain. } { the receiver will get no more messages by the application. } { assertion: receiver is definitely registered! } { ------------------------------------------------------------ } destructor TReceiver.Done; var n, r : TReceiverPtr; begin r := @self; if receiverChain = r then receiverChain := r^.nextReceiver else begin n := receiverChain; while n^.nextReceiver <> r do n := n^.nextReceiver; n^.nextReceiver := r^.nextReceiver; end; end; { ------------------------------------------------------------ } { the following methods are kind of dummy procedures that } { pass the message to the next receiver until there is one. } { descendants may overide the methods the are interested in. } { ------------------------------------------------------------ } procedure TReceiver.RedrawMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.RedrawMessage( handle ); end; procedure TReceiver.CloseMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.CloseMessage( handle ); end; procedure TReceiver.MoveMessage( handle, x, y : Integer ); begin if nextReceiver <> nil then nextReceiver^.MoveMessage( handle, x, y ); end; procedure TReceiver.SizeMessage( handle, w, h : Integer ); begin if nextReceiver <> nil then nextReceiver^.SizeMessage( handle, w, h ); end; procedure TReceiver.FullMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.FullMessage( handle ); end; procedure TReceiver.LineUpMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.LineUpMessage( handle ); end; procedure TReceiver.LineDownMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.LineDownMessage( handle ); end; procedure TReceiver.PageUpMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.PageUpMessage( handle ); end; procedure TReceiver.PageDownMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.PageDownMessage( handle ); end; procedure TReceiver.PageLeftMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.PageLeftMessage( handle ); end; procedure TReceiver.PageRightMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.PageRightMessage( handle ); end; procedure TReceiver.ColumnLeftMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.ColumnLeftMessage( handle ); end; procedure TReceiver.ColumnRightMessage( handle : Integer ); begin if nextReceiver <> nil then nextReceiver^.ColumnRightMessage( handle ); end; procedure TReceiver.HorizSliderMessage( handle, relPos : Integer ); begin if nextReceiver <> nil then nextReceiver^.HorizSliderMessage( handle, relPos ); end; procedure TReceiver.VertSliderMessage( handle, relPos : Integer ); begin if nextReceiver <> nil then nextReceiver^.VertSliderMessage( handle, relPos ); end; procedure TReceiver.KeyPressedMessage( keycode : Integer ); begin if nextReceiver <> nil then nextReceiver^.KeyPressedMessage( keycode ); end; procedure TReceiver.MenuSelectedMessage( title, item : Integer ); begin if nextReceiver <> nil then nextReceiver^.MenuSelectedMessage( title, item ); end; procedure TReceiver.AccessoryOpenMessage; begin if nextReceiver <> nil then nextReceiver^.AccessoryOpenMessage; end; procedure TReceiver.AccessoryCloseMessage; begin if nextReceiver <> nil then nextReceiver^.AccessoryCloseMessage; end; { ------------------------------------------------------------ } { initialize the empty receiver chain. } { ------------------------------------------------------------ } begin receiverChain := nil; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT RESOURCES } { (c) 1992 Pure Software GmbH } { } { this unit enables the usage of linked-in GEM resource files. } { therefore the .RSC-file must be converted into an object } { file using BINOBJ. } { } { } { 1. Execute BINOBJ to create an object file, i.e. } { BINOBJ myrsc.rcs myrsc MyResource } { } { 2. Include the object file into the primary file using the } { $L-directive. } { } { 3. Declare the entry point for the resource file which must } { be the same identifier used at 1., i.e. } { procedure MyResource; external; (*$L myrsc *) } { } { 4. Initialize the linked-in resource file: } { resourcePool := InitResourcePool( @MyResource ); } { } { 5. now the variable resourcePool can be used to inquire the } { start address of an AESTree: } { menuTree := GetResource( resourcePool, MYMENU ); } { menu_bar( menuTree, 1 ); } { } { 6. before program termination you must call FreeResourcePool } { FreeResourcePool( resourcePool ); } { ------------------------------------------------------------ } unit Resources; interface uses Gem; type TResource = AESTreePtr; TResourcePoolPtr = ^TResourcePool; TResourcePool = Pointer; function InitResourcePool( unfixedResource : Pointer ) : TResourcePoolPtr; procedure FreeResourcePool( pool : TResourcePoolPtr ); function GetResource( pool : TResourcePoolPtr; poolIndex : Word ) : TResource; { ============================================================ } implementation {$X+} { ------------------------------------------------------------ } { these are the maximum numbers of the named data structures } { a resource file can contain. } { ------------------------------------------------------------ } const MaxAESObjects = 2730; MaxTedinfos = 2340; MaxIconBlocks = 1820; MaxBitBlocks = 4681; { ------------------------------------------------------------ } { the following record describes the header of a resource } { files. for further information see the GEM literature. } { ------------------------------------------------------------ } type ResourceHeaderTypePtr = ^ResourceHeaderType; ResourceHeaderType = record rsh_vrsn : Word; rsh_object : Word; rsh_tedinfo : Word; rsh_iconblk : Word; rsh_bitblk : Word; rsh_frstr : Word; rsh_string : Word; rsh_imdata : Word; rsh_frimg : Word; rsh_trindex : Word; rsh_nobs : Word; rsh_ntree : Word; rsh_nted : Word; rsh_nib : Word; rsh_nbb : Word; rsh_nstring : Word; rsh_nimages : Word; rsh_rssize : Word; end; { ------------------------------------------------------------ } { this variant record allows convenient accessing the resource } { file bytewise and also the resource header. } { ------------------------------------------------------------ } ResourceFileTypePtr = ^ResourceFileType; ResourceFileType = record case Integer of 1: ( resourceHeader : ResourceHeaderType ); 2: ( resourceData : Array[0..65535] of Byte ); end; { ------------------------------------------------------------ } { some data structures to deal with the different components } { of a resource file. } { ------------------------------------------------------------ } TedinfoArrayPtr = ^TedinfoArray; TedinfoArray = Array[0..MaxTedinfos] of TEDINFO; IconBlockArrayPtr = ^IconBlockArray; IconBlockArray = Array[0..MaxIconBlocks] of ICONBLK; BitBlockArrayPtr = ^BitBlockArray; BitBlockArray = Array[0..MaxBitBlocks] of BITBLK; AESTreePtrArrayPtr = ^AESTreePtrArray; AESTreePtrArray = Array[0..MaxAESObjects] of AESTreePtr; { ------------------------------------------------------------ } { FIXRSC means that the relative addresses of the components } { of the resource file should be fixed to absolute addresses. } { UNFIXRSC is the counteroperation. } { ------------------------------------------------------------ } FixMode = ( FIXRSC, UNFIXRSC ); { ------------------------------------------------------------ } { the gem function rsrc_obfix transforms relative coordinates } { to absolute ones. this procedure works the the other way } { round. } { the low byte of a relative coordinate contains a character- } { distance and the high byte a remaining pixel distance. } { ------------------------------------------------------------ } procedure AbsToRelCoords( var coord : Integer; defCharSize : Integer ); var px, ch : Integer; begin ch := coord div defCharSize; px := coord mod defCharSize; coord := ( px shl 8 ) + ch; end; { ------------------------------------------------------------ } { since there seem to be some problems using rsrc_obfix we } { will do it ourselves. } { ------------------------------------------------------------ } procedure RelToAbsCoords( var coord : Integer; defCharSize : Integer ); var px, ch : Integer; begin ch := ( coord and $00ff ) * defCharSize; px := coord shr 8; coord := ch + px; end; { ------------------------------------------------------------ } { the procedure FixResourcePool handles, depending on the } { parameter mode, the fixing respectively the un-fixing of the } { relative addresses of a resource file by adding or } { substracting the start address of the resource file. } { ------------------------------------------------------------ } procedure FixResourcePool( unfixedResource : Pointer; mode : FixMode ); var resourceFile : ResourceFileTypePtr; resourceHeader : ResourceHeaderTypePtr; tree : AESTreePtr; treePool : AESTreePtrArrayPtr; tedinfo : TedinfoArrayPtr; iconblk : IconBlockArrayPtr; bitblk : BitBlockArrayPtr; obj, objCnt, objType : Integer; defWidth, defHeight, dummy : Integer; offset : LongInt; begin offset := LongInt( unfixedResource ); if mode = UNFIXRSC then offset := -offset; resourceFile := unfixedResource; resourceHeader := @resourceFile^.resourceHeader; graf_handle( defWidth, defHeight, dummy, dummy ); tree := @resourceFile^.resourceData[resourceHeader^.rsh_object]; for obj := 0 to resourceHeader^.rsh_nobs - 1 do begin if mode = FIXRSC then begin RelToAbsCoords( tree^[obj].ob_x, defWidth ); RelToAbsCoords( tree^[obj].ob_y, defHeight ); RelToAbsCoords( tree^[obj].ob_width, defWidth ); RelToAbsCoords( tree^[obj].ob_height, defHeight ); end else begin AbsToRelCoords( tree^[obj].ob_x, defWidth ); AbsToRelCoords( tree^[obj].ob_y, defHeight ); AbsToRelCoords( tree^[obj].ob_width, defWidth ); AbsToRelCoords( tree^[obj].ob_height, defHeight ); end; objType := tree^[obj].ob_type; if ( objType = G_TEXT ) or ( objType = G_BOXTEXT ) or ( objType = G_FTEXT ) or ( objType = G_FBOXTEXT ) or ( objType = G_BUTTON ) or ( objType = G_STRING ) or ( objType = G_TITLE ) or ( objType = G_ICON ) or ( objType = G_IMAGE ) then begin Inc( tree^[obj].ob_spec.index, offset ); end; end; tedinfo := @resourceFile^.resourceData[resourceHeader^.rsh_tedinfo]; for obj := 0 to resourceHeader^.rsh_nted - 1 do begin Inc( LongInt( tedinfo^[obj].te_ptext ), offset ); Inc( LongInt( tedinfo^[obj].te_ptmplt ), offset ); Inc( LongInt( tedinfo^[obj].te_pvalid ), offset ); end; iconblk := @resourceFile^.resourceData[resourceHeader^.rsh_iconblk]; for obj := 0 to resourceHeader^.rsh_nib - 1 do begin Inc( LongInt( iconblk^[obj].ib_pmask ), offset ); Inc( LongInt( iconblk^[obj].ib_pdata ), offset ); Inc( LongInt( iconblk^[obj].ib_ptext ), offset ); end; bitblk := @resourceFile^.resourceData[resourceHeader^.rsh_bitblk]; for obj := 0 to resourceHeader^.rsh_nbb - 1 do Inc( LongInt( bitblk^[obj].bi_pdata ), offset ); treePool := @resourceFile^.resourceData[resourceHeader^.rsh_trindex]; for obj := 0 to resourceHeader^.rsh_ntree - 1 do Inc( LongInt( treePool^[obj] ), offset ); end; { ------------------------------------------------------------ } { this procedure start the un-fixing process. } { ------------------------------------------------------------ } procedure FreeResourcePool( pool : TResourcePoolPtr ); begin FixResourcePool( pool, UNFIXRSC ); end; { ------------------------------------------------------------ } { this procedure initializes the resource file and the GEM! } { ------------------------------------------------------------ } function InitResourcePool( unfixedResource : Pointer ) : TResourcePoolPtr; var resourceFile : ResourceFileTypePtr; resourceHeader : ResourceHeaderTypePtr; treePool : AESTreePtrArrayPtr; begin FixResourcePool( unfixedResource, FIXRSC ); resourceFile := unfixedResource; resourceHeader := @resourceFile^.resourceHeader; treePool := @resourceFile^.resourceData[resourceHeader^.rsh_trindex]; GEM_pb.global[5] := Word( LongInt( treePool ) shr 16 ); GEM_pb.global[6] := Word( treePool ); InitResourcePool := unfixedResource; end; { ------------------------------------------------------------ } { this function returns the address of a specific AESTree of } { the resource file. } { ------------------------------------------------------------ } function GetResource( pool : TResourcePoolPtr; poolIndex : Word ) : TResource; var resourceFile : ResourceFileTypePtr; resourceHeader : ResourceHeaderTypePtr; treePool : AESTreePtrArrayPtr; begin resourceFile := ResourceFileTypePtr( pool ); resourceHeader := @resourceFile^.resourceHeader; treePool := @resourceFile^.resourceData[resourceHeader^.rsh_trindex]; GetResource := treePool^[poolIndex]; end; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT TEXTWINDOWS } { (c) 1992 Pure Software GmbH } { } { the unit TextWindows provides a window object that is } { capable to deal with text lines. } { ------------------------------------------------------------ } unit TextWindows; interface uses Windows; type TTextWindowPtr = ^TTextWindow; TTextWindow = object ( TWindow ) columnCount : Integer; lineCount : LongInt; firstColumn : Integer; firstLine : LongInt; visibleColumns : Integer; visibleLines : LongInt; constructor Init; procedure ClearRestOfLine( line : LongInt; startCol : Integer ); procedure WriteLine( line : LongInt ); procedure Scroll( horiz, vert : Integer ); procedure SetSlidersAndRedraw; function GetLine( line : LongInt ) : String; virtual; procedure SetSize( w, h : Integer ); virtual; procedure SetFirstLine( newFirstLine : LongInt ); virtual; procedure SetFirstColumn( newFirstColumn : Integer ); virtual; procedure DrawContents; virtual; procedure LineUp; virtual; procedure LineDown; virtual; procedure PageUp; virtual; procedure PageDown; virtual; procedure PageLeft; virtual; procedure PageRight; virtual; procedure ColumnLeft; virtual; procedure ColumnRight; virtual; procedure PosVertSlider( relPos : Integer ); virtual; procedure PosHorizSlider( relPos : Integer ); virtual; procedure KeyPressed( keycode : Integer ); virtual; end; { ============================================================ } implementation uses GemInit, Gem; {$X+} var dummy : Integer; { ------------------------------------------------------------ } { the contructor intializes the object fields. } { ------------------------------------------------------------ } constructor TTextWindow.Init; begin TWindow.Init; columnCount := 256; horizTotal := columnCount; lineCount := 0; firstColumn := 0; firstLine := 0; visibleLines := 0; visibleColumns := 0; end; { ------------------------------------------------------------ } { this is a dummy method that always returns an empty string. } { descendants will override this method to return the text of } { the corresponding line. } { ------------------------------------------------------------ } function TTextWindow.GetLine( line : LongInt ) : String; begin GetLine := ''; end; { ------------------------------------------------------------ } { for text windows this method calculates the number of } { visible lines and columns and then calls the ancestor. } { ------------------------------------------------------------ } procedure TTextWindow.SetSize( w, h : Integer ); begin visibleLines := h div GemInit.charHeight; if h mod GemInit.charHeight <> 0 then Inc( visibleLines ); vertVisible := visibleLines; visibleColumns := w div GemInit.charWidth; if w mod GemInit.charWidth <> 0 then Inc( visibleColumns ); horizVisible := visibleColumns; TWindow.SetSize( w, h ); end; { ------------------------------------------------------------ } { this method clears the rest of line beginning form column } { startCol (if startCol is 0 the whole line will be cleared). } { attention: ClearRestOfLine takes window relative parameters! } { ------------------------------------------------------------ } procedure TTextWindow.ClearRestOfLine( line : LongInt; startCol : Integer ); var pxyarray : ARRAY_4; begin begin pxyarray[0] := innerFrame.x + startCol * GemInit.charWidth; pxyarray[1] := innerFrame.y + line * GemInit.charHeight; pxyarray[2] := innerFrame.x + innerFrame.w - 1; pxyarray[3] := pxyarray[1] + GemInit.charHeight - 1; vr_recfl( GemInit.vdiHandle, pxyarray ); end end; { ------------------------------------------------------------ } { the method TTextWindow.WriteLine prints a line. } { ------------------------------------------------------------ } procedure TTextWindow.WriteLine( line : LongInt ); var x, y : Integer; len : Integer; str : String; begin if line >= lineCount then ClearRestOfLine( line - firstLine, 0 ) else begin str := Copy( GetLine( line ), firstColumn + 1, visibleColumns ); len := Length( str ); if len > 0 then begin x := innerFrame.x; y := innerFrame.y + ( line - firstLine ) * GemInit.charHeight; v_gtext( GemInit.vdiHandle, x, y, str ); end; if len < visibleColumns then ClearRestOfLine( line - firstLine, len ); end; end; { ------------------------------------------------------------ } { the method TTextWindow.Scroll scrolls the window contents } { horiz columns and vert lines. negative values indicate } { upward respectively left hand movement. the sliders are set } { automatically. } { ------------------------------------------------------------ } procedure TTextWindow.Scroll( horiz, vert : Integer ); var screenMFDB : MFDB; pxyarray : ARRAY_8; clipArray : ARRAY_4; height : Integer; l, line : LongInt; begin if ( horiz <> 0 ) and ( vert <> 0 ) then SetSlidersAndRedraw else if horiz <> 0 then begin Redraw; SetHorizSlider; end else if vert <> 0 then begin if ( not IsTop ) or ( abs( vert ) >= visibleLines ) then Redraw else begin pxyarray[0] := innerFrame.x; pxyarray[2] := innerFrame.x + innerFrame.w - 1; pxyarray[4] := innerFrame.x; pxyarray[6] := innerFrame.x + innerFrame.w - 1; height := abs( vert ) * GemInit.charHeight; if vert > 0 then begin line := firstLine + visibleLines - vert - 1; pxyarray[1] := innerFrame.y + height; pxyarray[3] := innerFrame.y + innerFrame.h - 1; pxyarray[5] := innerFrame.y; pxyarray[7] := innerFrame.y + innerFrame.h - 1 - height; end else begin line := firstLine; pxyarray[1] := innerFrame.y; pxyarray[3] := innerFrame.y + innerFrame.h - 1 - height; pxyarray[5] := innerFrame.y + height; pxyarray[7] := innerFrame.y + innerFrame.h - 1; end; wind_update( BEG_UPDATE ); graf_mouse( M_OFF, nil ); screenMFDB.fd_addr := nil; vro_cpyfm( GemInit.vdiHandle, 3, pxyarray, screenMFDB, screenMFDB ); clipArray[0] := innerFrame.x; clipArray[1] := innerFrame.y; clipArray[2] := innerFrame.x + innerFrame.w - 1; clipArray[3] := innerFrame.y + innerFrame.h - 1; vs_clip( GemInit.vdiHandle, 1, clipArray ); for l := line to line + abs( vert ) do WriteLine( l ); vs_clip( GemInit.vdiHandle, 0, clipArray ); graf_mouse( M_ON, nil ); wind_update( END_UPDATE ); end; SetVertSlider; end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one line upwards. } { ------------------------------------------------------------ } procedure TTextWindow.LineUp; begin if firstLine > 0 then begin SetFirstLine( firstLine - 1 ); Scroll( 0, -1 ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one line downwards. } { ------------------------------------------------------------ } procedure TTextWindow.LineDown; begin if firstLine < lineCount - visibleLines then begin SetFirstLine( firstLine + 1 ); Scroll( 0, 1 ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one page upwards. } { ------------------------------------------------------------ } procedure TTextWindow.PageUp; var oldFirstLine : LongInt; begin if firstLine > 0 then begin oldFirstLine := firstLine; SetFirstLine( firstLine - visibleLines ); if firstLine < 0 then SetFirstLine( 0 ); Scroll( 0, firstLine - oldFirstLine ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one page downwards. } { ------------------------------------------------------------ } procedure TTextWindow.PageDown; var oldFirstLine : LongInt; begin if firstLine < lineCount - visibleLines then begin oldFirstLine := firstLine; SetFirstLine( firstLine + visibleLines ); if firstLine > lineCount - visibleLines then SetFirstLine( lineCount - visibleLines ); Scroll( 0, firstLine - oldFirstLine ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one column to the } { left. } { ------------------------------------------------------------ } procedure TTextWindow.ColumnLeft; begin if firstColumn > 0 then begin SetFirstColumn( firstColumn - 1 ); Scroll( -1, 0 ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one column to the } { right. } { ------------------------------------------------------------ } procedure TTextWindow.ColumnRight; begin if firstColumn < columnCount - visibleColumns then begin SetFirstColumn( firstColumn + 1 ); Scroll( 1, 0 ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one page to the } { left. } { ------------------------------------------------------------ } procedure TTextWindow.PageLeft; var oldFirstColumn : Integer; begin if firstColumn > 0 then begin oldFirstColumn := firstColumn; SetFirstColumn( firstColumn - visibleColumns ); if firstColumn < 0 then SetFirstColumn( 0 ); Scroll( firstColumn - oldFirstColumn, 0 ); end; end; { ------------------------------------------------------------ } { this methods scrolls the window contents one page to the } { right. } { ------------------------------------------------------------ } procedure TTextWindow.PageRight; var oldFirstColumn : Integer; begin if firstColumn < columnCount - visibleColumns then begin oldFirstColumn := firstColumn; SetFirstColumn( firstColumn + visibleColumns ); if firstColumn > columnCount - visibleColumns then SetFirstColumn( columnCount - visibleColumns ); Scroll( firstColumn - oldFirstColumn, 0 ); end; end; { ------------------------------------------------------------ } { the DrawContents method says what is to be done to draw the } { window contents. here all visible lines are printed. } { ------------------------------------------------------------ } procedure TTextWindow.DrawContents; var line : LongInt; begin for line := firstLine to firstLine + visibleLines do WriteLine( line ); end; { ------------------------------------------------------------ } { the method TTextWindow.PosVertSlider sets the vertical } { slider to the relative position relPos (range from 1 to } { 1000). It calculates the new first visible line and then } { calls the ancestor. } { ------------------------------------------------------------ } procedure TTextWindow.PosVertSlider( relPos : Integer ); var newFirstLine : LongInt; h : LongInt; begin h := LongInt( relPos ) * ( lineCount - visibleLines ); newFirstLine := h div 1000; if h mod 1000 >= 500 then Inc( newFirstLine ); if newFirstLine <> firstLine then begin SetFirstLine( newFirstLine ); TWindow.PosVertSlider( relPos ); end; end; { ------------------------------------------------------------ } { the method TTextWindow.PosHorizSlider sets the horizontal } { slider to the relative position relPos (range from 1 to } { 1000). It calculates the new first visible column and then } { calls the ancestor. } { ------------------------------------------------------------ } procedure TTextWindow.PosHorizSlider( relPos : Integer ); var newFirstCol : Integer; h : LongInt; begin h := LongInt( relPos ) * ( columnCount - visibleColumns ); newFirstCol := h div 1000; if h mod 1000 >= 500 then Inc( newFirstCol ); if newFirstCol <> firstColumn then begin SetFirstColumn( newFirstCol ); TWindow.PosHorizSlider( relPos ); end; end; { ------------------------------------------------------------ } { the method TTextWindow.KeyPressed handles keyboard input. } { ------------------------------------------------------------ } procedure TTextWindow.KeyPressed( keycode : Integer ); begin case keyCode of Home: begin SetFirstLine( 0 ); SetFirstColumn( 0 ); SetSlidersAndRedraw; end; Shift_Home: begin SetFirstLine( lineCount - visibleLines ); SetFirstColumn( 0 ); SetSlidersAndRedraw; end; Cur_Up: LineUp; Cur_Down: LineDown; Shift_CU: PageUp; Shift_CD: PageDown; Cur_Left: ColumnLeft; Cur_Right: ColumnRight; Shift_CL: PageLeft; Shift_CR: PageRight; else TReceiver.KeyPressedMessage( keycode ); end; end; { ------------------------------------------------------------ } { this method redraws the window contents and sets both } { sliders. } { ------------------------------------------------------------ } procedure TTextWindow.SetSlidersAndRedraw; begin Redraw; SetHorizSlider; SetVertSlider; end; { ------------------------------------------------------------ } { this method assigns a new value to the firstLine field. it } { also changes the vertStart field of the TWindow object. this } { is a good example for data encapsulation. } { ------------------------------------------------------------ } procedure TTextWindow.SetFirstLine( newFirstLine : LongInt ); begin firstLine := newFirstLine; vertStart := firstLine; end; { ------------------------------------------------------------ } { this method assigns a new value to the firstColumn field. it } { also changes the horizStart field of the TWindow object. } { this is another good example for data encapsulation. } { ------------------------------------------------------------ } procedure TTextWindow.SetFirstColumn( newFirstColumn : Integer ); begin firstColumn := newFirstColumn; horizStart := firstColumn; end; { ------------------------------------------------------------ } { the unit initializes the vdi output for its own purposes. } { ------------------------------------------------------------ } begin vsf_interior( GemInit.vdiHandle, 0 ); vsf_style( GemInit.vdiHandle, 0 ); vst_alignment( GemInit.vdiHandle, 0, 5, dummy, dummy ); end. { ============================================================ } { ------------------------------------------------------------ } { UNIT WINDOWS } { (c) 1992 Pure Software GmbH } { } { the unit windows provides a generic window object that is } { capable to handle some of the daily window routine. } { ------------------------------------------------------------ } unit Windows; interface uses Receiver; type Rect = record x, y, w, h : Integer; end; TWindowPtr = ^TWindow; TWindow = object ( TReceiver ) winHandle : Integer; innerFrame : Rect; outerFrame : Rect; prevFrame : Rect; fullFrame : Rect; isVisible : Boolean; fullFlag : Boolean; winName : String; horizTotal : LongInt; horizVisible : LongInt; horizStart : LongInt; vertTotal : LongInt; vertVisible : LongInt; vertStart : LongInt; constructor Init; destructor Done; procedure RedrawMessage( handle : Integer ); virtual; procedure CloseMessage( handle : Integer ); virtual; procedure MoveMessage( handle, x, y : Integer ); virtual; procedure SizeMessage( handle, w, h : Integer ); virtual; procedure FullMessage( handle : Integer ); virtual; procedure LineUpMessage( handle : Integer ); virtual; procedure LineDownMessage( handle : Integer ); virtual; procedure PageUpMessage( handle : Integer ); virtual; procedure PageDownMessage( handle : Integer ); virtual; procedure PageLeftMessage( handle : Integer ); virtual; procedure PageRightMessage( handle : Integer ); virtual; procedure ColumnLeftMessage( handle : Integer ); virtual; procedure ColumnRightMessage( handle : Integer ); virtual; procedure HorizSliderMessage( handle, relPos : Integer ); virtual; procedure VertSliderMessage( handle, relPos : Integer ); virtual; procedure KeyPressedMessage( keycode : Integer ); virtual; procedure SetPosition( x, y : Integer ); virtual; procedure GetPosition( var x, y : Integer ); procedure GetSize( var w, h : Integer ); procedure SetSize( w, h : Integer ); virtual; function GetName : String; procedure SetName( name : String ); procedure SetHorizSlider; procedure SetVertSlider; function Open( x, y, w, h : Integer ) : Boolean; virtual; procedure DrawContents; virtual; function IsTop : Boolean; procedure Redraw; virtual; function Close : Boolean; virtual; procedure LineUp; virtual; procedure LineDown; virtual; procedure PageUp; virtual; procedure PageDown; virtual; procedure PageLeft; virtual; procedure PageRight; virtual; procedure ColumnLeft; virtual; procedure ColumnRight; virtual; procedure PosVertSlider( relPos : Integer ); virtual; procedure PosHorizSlider( relPos : Integer ); virtual; procedure KeyPressed( keycode : Integer ); virtual; private buffer : String; end; { ============================================================ } implementation {$X+} uses Gem, GemInit; const winKind = NAME or CLOSER or FULLER or MOVER or SIZER or UPARROW or DNARROW or VSLIDE or LFARROW or RTARROW or HSLIDE; minWidth = 100; minHeight = 100; var maxFrame : Rect; { ------------------------------------------------------------ } { this procedure converts inner frames to outer frames. } { ------------------------------------------------------------ } procedure OuterToInnerFrame( var outerFrame, innerFrame : Rect ); forward; procedure InnerToOuterFrame( var innerFrame, outerFrame : Rect ); begin wind_calc( WC_BORDER, winKind, innerFrame.x, innerFrame.y, innerFrame.w, innerFrame.h, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h ); if outerFrame.x < maxFrame.x then begin outerFrame.x := maxFrame.x; OuterToInnerFrame( outerFrame, innerFrame ); end; if outerFrame.y < maxFrame.y then begin outerFrame.y := maxFrame.y; OuterToInnerFrame( outerFrame, innerFrame ); end; end; { ------------------------------------------------------------ } { this procedure converts inner frames to outer frames. } { ------------------------------------------------------------ } procedure OuterToInnerFrame( var outerFrame, innerFrame : Rect ); begin wind_calc( WC_WORK, winKind, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h, innerFrame.x, innerFrame.y, innerFrame.w, innerFrame.h ); if innerFrame.w < minWidth then begin innerFrame.w := minWidth; InnerToOuterFrame( innerFrame, outerFrame ); end; if innerFrame.h < minHeight then begin innerFrame.h := minHeight; InnerToOuterFrame( innerFrame, outerFrame ); end; end; { ------------------------------------------------------------ } { the contructor TWindow.Init initializes the object fields. } { ------------------------------------------------------------ } constructor TWindow.Init; begin TReceiver.Init; horizTotal := 0; horizVisible := 0; horizStart := 0; vertTotal := 0; vertVisible := 0; vertStart := 0; fullFlag := False; winHandle := -1; isVisible := False; outerFrame := maxFrame; OuterToInnerFrame( outerFrame, innerFrame ); fullFrame := innerFrame; end; { ------------------------------------------------------------ } { the destructor TWindow.Done closes the gem window unless } { already happend and afterwards frees the gem window. } { ------------------------------------------------------------ } destructor TWindow.Done; begin if isVisible then Close; TReceiver.Done; end; { ------------------------------------------------------------ } { if the redraw message is for this window a redraw will be } { started. Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.RedrawMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.RedrawMessage( handle ) else Redraw; end; { ------------------------------------------------------------ } { if the close message is for this window it will be closed. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.CloseMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.CloseMessage( handle ) else Close; end; { ------------------------------------------------------------ } { if the move message is for this window it will be moved. } { Otherwise pass the message to the next receiver. } { Because x und y are coordinates for the outer frame they } { must be converted to inner frame coordinates, because all } { window methods work relative to the inner frame. } { ------------------------------------------------------------ } procedure TWindow.MoveMessage( handle, x, y : Integer ); var ro, ri : Rect; begin if handle <> winHandle then TReceiver.MoveMessage( handle, x, y ) else begin ro.x := x; ro.y := y; ro.w := outerFrame.w; ro.h := outerFrame.h; OuterToInnerFrame( ro, ri ); SetPosition( ri.x, ri.y ); end; end; { ------------------------------------------------------------ } { if the size message is for this window it will be resized. } { Otherwise pass the message to the next receiver. } { Because w und h are the width and height of the outer frame } { they must be converted to inner frame sizes, because all } { window methods work relative to the inner frame. } { ------------------------------------------------------------ } procedure TWindow.SizeMessage( handle, w, h : Integer ); var ro, ri : Rect; begin if handle <> winHandle then TReceiver.SizeMessage( handle, w, h ) else begin ro.x := outerFrame.x; ro.y := outerFrame.y; ro.w := w; ro.h := h; OuterToInnerFrame( ro, ri ); SetSize( ri.w, ri.h ); end; end; { ------------------------------------------------------------ } { if the full message is for this window it will be set to its } { maximum size. Otherwise pass the message to the next } { receiver. } { ------------------------------------------------------------ } procedure TWindow.FullMessage( handle : Integer ); var newOuterFrame : Rect; begin if handle <> winHandle then TReceiver.FullMessage( handle ) else begin if fullFlag then newOuterFrame := prevFrame else begin wind_get( handle, WF_FULLXYWH, newOuterFrame.x, newOuterFrame.y, newOuterFrame.w, newOuterFrame.h ); prevFrame := outerFrame; end; fullFlag := not fullFlag; MoveMessage( handle, newOuterFrame.x, newOuterFrame.y ); SizeMessage( handle, newOuterFrame.w, newOuterFrame.h ); end; end; { ------------------------------------------------------------ } { if the line up message is for this window the contents will } { be scrolled one line upwards. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.LineUpMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.LineUpMessage( handle ) else LineUp; end; { ------------------------------------------------------------ } { if the line down message is for this window the contents } { will be scrolled one line downwards. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.LineDownMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.LineDownMessage( handle ) else LineDown; end; { ------------------------------------------------------------ } { if the page up message is for this window the contents will } { be scrolled one page upwards. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.PageUpMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.PageUpMessage( handle ) else PageUp; end; { ------------------------------------------------------------ } { if the page down message is for this window the contents } { will be scrolled one page downwards. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.PageDownMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.PageDownMessage( handle ) else PageDown; end; { ------------------------------------------------------------ } { if the page left message is for this window the contents } { will be scrolled one page to the left. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.PageLeftMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.PageLeftMessage( handle ) else PageLeft; end; { ------------------------------------------------------------ } { if the page right message is for this window the contents } { will be scrolled one page to the right. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.PageRightMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.PageRightMessage( handle ) else PageRight; end; { ------------------------------------------------------------ } { if the column left message is for this window the contents } { will be scrolled one column to the left. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.ColumnLeftMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.ColumnLeftMessage( handle ) else ColumnLeft; end; { ------------------------------------------------------------ } { if the column right message is for this window the contents } { will be scrolled one column to the right. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.ColumnRightMessage( handle : Integer ); begin if handle <> winHandle then TReceiver.ColumnRightMessage( handle ) else ColumnRight; end; { ------------------------------------------------------------ } { if the horizontal slider moved message is for this window } { the contents will be adjusted to the new slider position. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.HorizSliderMessage( handle, relPos : Integer ); begin if handle <> winHandle then TReceiver.HorizSliderMessage( handle, relPos ) else PosHorizSlider( relPos ); end; { ------------------------------------------------------------ } { if the vertical slider moved message is for this window } { the contents will be adjusted to the new slider position. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.VertSliderMessage( handle, relPos : Integer ); begin if handle <> winHandle then TReceiver.VertSliderMessage( handle, relPos ) else PosVertSlider( relPos ); end; { ------------------------------------------------------------ } { if the key pressed message is for this window the method } { KeyPressed method will be called which handles keyboard } { input. } { Otherwise pass the message to the next receiver. } { ------------------------------------------------------------ } procedure TWindow.KeyPressedMessage( keycode : Integer ); begin if not IsTop then TReceiver.KeyPressedMessage( keycode ) else KeyPressed( keycode ); end; { ------------------------------------------------------------ } { this method returns the coordinates of the upper left } { corner of the inner frame of the window. } { ------------------------------------------------------------ } procedure TWindow.GetPosition( var x, y : Integer ); begin x := innerFrame.x; y := innerFrame.y; end; { ------------------------------------------------------------ } { this method moves a window to the coordinates x and y. } { as usually x and y represent the upper left corner of the } { inner frame of the window. } { ------------------------------------------------------------ } procedure TWindow.SetPosition( x, y : Integer ); begin innerFrame.x := x; innerFrame.y := y; InnerToOuterFrame( innerFrame, outerFrame ); if isVisible then wind_set( winHandle, WF_CURRXYWH, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h ); end; { ------------------------------------------------------------ } { this method returns the width and height of the inner frame } { of the window. the inner frame is the ractangle used for } { application specific output. } { ------------------------------------------------------------ } procedure TWindow.GetSize( var w, h : Integer ); begin w := innerFrame.w; h := innerFrame.h; end; { ------------------------------------------------------------ } { this method sets the inner frame width and height of the } { window. } { ------------------------------------------------------------ } procedure TWindow.SetSize( w, h : Integer ); begin innerFrame.w := w; innerFrame.h := h; InnerToOuterFrame( innerFrame, outerFrame ); if isVisible then wind_set( winHandle, WF_CURRXYWH, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h ); SetHorizSlider; SetVertSlider; end; { ------------------------------------------------------------ } { this method returns the current window name. } { ------------------------------------------------------------ } function TWindow.GetName : String; begin GetName := winName; end; { ------------------------------------------------------------ } { this method sets a new window name. } { ------------------------------------------------------------ } procedure TWindow.SetName( name : String ); begin winName := name; if winHandle > 0 then WindSetTitle( winHandle, name, buffer ); end; { ------------------------------------------------------------ } { the method TWindow.SetHorizSlider sets the size and the } { position of the horizontal slider. } { ------------------------------------------------------------ } procedure TWindow.SetHorizSlider; var siz, pos : LongInt; begin if horizTotal = 0 then siz := 1000 else begin siz := 1000 * horizVisible div horizTotal; if siz > 1000 then siz := 1000; end; if winHandle >= 0 then wind_set( winHandle, WF_HSLSIZE, Integer( siz ), 0, 0, 0 ); pos := horizTotal - horizVisible; if pos <> 0 then begin pos := 1000 * horizStart div pos; if pos > 1000 then pos := 1000; end; if winHandle >= 0 then wind_set( winHandle, WF_HSLIDE, Integer( pos ), 0, 0, 0 ); end; { ------------------------------------------------------------ } { the method TWindow.SetVertSlider sets the size and the } { position of the vertical slider. } { ------------------------------------------------------------ } procedure TWindow.SetVertSlider; var siz, pos : LongInt; begin if vertTotal = 0 then siz := 1000 else begin siz := 1000 * vertVisible div vertTotal; if siz > 1000 then siz := 1000; end; if winHandle >= 0 then wind_set( winHandle, WF_VSLSIZE, Integer( siz ), 0, 0, 0 ); pos := vertTotal - vertVisible; if pos <> 0 then begin pos := 1000 * vertStart div pos; if pos > 1000 then pos := 1000; end; if winHandle >= 0 then wind_set( winHandle, WF_VSLIDE, Integer( pos ), 0, 0, 0 ); end; { ------------------------------------------------------------ } { this method opens a window at the coordinates x and y with } { the width w and the height h and returns true if the window } { could be opened. } { ------------------------------------------------------------ } function TWindow.Open( x, y, w, h : Integer ) : Boolean; begin winHandle := wind_create( winKind, maxFrame.x, maxFrame.y, maxFrame.w, maxFrame.h ); if winHandle >= 0 then begin innerFrame.x := x; innerFrame.y := y; InnerToOuterFrame( innerFrame, outerFrame ); SetSize( w, h ); WindSetTitle( winHandle, winName, buffer ); if wind_open( winHandle, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h ) = 0 then Open := false else begin isVisible := true; wind_calc( WC_WORK, winKind, outerFrame.x, outerFrame.y, outerFrame.w, outerFrame.h, innerFrame.x, innerFrame.y, innerFrame.w, innerFrame.h ); Open := true; end; end else Open := false; end; { ------------------------------------------------------------ } { the method DrawContents is responsible for drawing the } { contents of the window. it must be overridden by the } { descendants of the TWindow object. } { ------------------------------------------------------------ } procedure TWindow.DrawContents; begin end; { ------------------------------------------------------------ } { this method tests wether the window is topmost. } { ------------------------------------------------------------ } function TWindow.IsTop : Boolean; var handle, dummy : Integer; begin wind_get( 0, WF_TOP, handle, dummy, dummy, dummy ); IsTop := handle = winHandle; end; { ------------------------------------------------------------ } { the TWindow.Redraw method initiates the redraw of the window } { contents. it clips the output so that there is no danger of } { destroying the screen contents. } { ------------------------------------------------------------ } procedure TWindow.Redraw; procedure RectIntersect( r1 : Rect; var r2 : Rect ); function Min( a, b : Integer ) : Integer; begin if a < b then Min := a else Min := b; end; function Max( a, b : Integer ) : Integer; begin if a > b then Max := a else Max := b; end; var x, y, w, h : Integer; begin x := Max( r1.x, r2.x ); y := Max( r1.y, r2.y ); w := Min( r1.x + r1.w, r2.x + r2.w ) - x; h := Min( r1.y + r1.h, r2.y + r2.h ) - y; r2.x := x; r2.y := y; r2.w := w; r2.h := h; end; var r : Rect; pxyarray : ARRAY_4; begin wind_update( BEG_UPDATE ); wind_get( winHandle, WF_FIRSTXYWH, r.x, r.y, r.w, r.h ); while ( r.w > 0 ) and ( r.h > 0 ) do begin RectIntersect( maxFrame, r ); if ( r.w > 0 ) and ( r.h > 0 ) then begin pxyarray[0] := r.x; pxyarray[1] := r.y; pxyarray[2] := r.x + r.w - 1; pxyarray[3] := r.y + r.h - 1; vs_clip( GemInit.vdiHandle, 1, pxyarray ); graf_mouse( M_OFF, nil ); DrawContents; graf_mouse( M_ON, nil ); vs_clip( GemInit.vdiHandle, 0, pxyarray ); end; wind_get( winHandle, WF_NEXTXYWH, r.x, r.y, r.w, r.h ); end; wind_update( END_UPDATE ); end; { ------------------------------------------------------------ } { this method closes a visible window and returns true if the } { window was already closed or it could be closed by now. It } { also resets some of the object fields for further use of the } { TWindow object. } { ------------------------------------------------------------ } function TWindow.Close : Boolean; begin wind_close( winHandle ); wind_delete( winHandle ); isVisible := false; horizTotal := 0; horizVisible := 0; horizStart := 0; vertTotal := 0; vertVisible := 0; vertStart := 0; fullFlag := False; Close := True; end; { ------------------------------------------------------------ } { here are some dummy methods that will be overridden by the } { descendants of TWindow. } { ------------------------------------------------------------ } procedure TWindow.LineUp; begin end; procedure TWindow.LineDown; begin end; procedure TWindow.PageUp; begin end; procedure TWindow.PageDown; begin end; procedure TWindow.PageLeft; begin end; procedure TWindow.PageRight; begin end; procedure TWindow.ColumnLeft; begin end; procedure TWindow.ColumnRight; begin end; { ------------------------------------------------------------ } { the method TWindow.PosHorizSlider sets the horizontal slider } { to the relative position relPos (range from 1 to 1000) and } { redraws the window contents. } { ------------------------------------------------------------ } procedure TWindow.PosHorizSlider( relPos : Integer ); begin wind_set( winHandle, WF_HSLIDE, relPos, 0, 0, 0 ); Redraw; end; { ------------------------------------------------------------ } { the method TWindow.PosVertSlider sets the vertical slider } { to the relative position relPos (range from 1 to 1000) and } { redraws the window contents. } { ------------------------------------------------------------ } procedure TWindow.PosVertSlider( relPos : Integer ); begin wind_set( winHandle, WF_VSLIDE, relPos, 0, 0, 0 ); Redraw; end; { ------------------------------------------------------------ } { this dummy method passes key strokes to the next receiver. } { it may be overridden be descendants. } { ------------------------------------------------------------ } procedure TWindow.KeyPressed( keycode : Integer ); begin TReceiver.KeyPressedMessage( keycode ); end; { ------------------------------------------------------------ } { the initialization part of the unit inquires the maximum } { size a window can take. } { ------------------------------------------------------------ } begin wind_get( 0, WF_WORKXYWH, maxFrame.x, maxFrame.y, maxFrame.w, maxFrame.h ); end. { ============================================================ } { ------------------------------------------------------------ } { UNIT MENU } { (c) 1992 Pure Software GmbH } { } { the unit menu provides a generic menu object. } { ------------------------------------------------------------ } unit Menu; interface uses Receiver, Resources; type TMenuPtr = ^TMenu; TMenu = object ( TReceiver ) menuTree : TResource; constructor Init( tree : TResource ); destructor Done; procedure MenuHandleItem( item : Integer ); virtual; procedure KeyPressedMessage( keycode : Integer ); virtual; procedure MenuSelectedMessage( title, item : Integer ); virtual; procedure KeyPressed( keycode : Integer ); virtual; end; { ============================================================ } implementation uses Gem; {$X+} { ------------------------------------------------------------ } { the constructor TMenu.Init shows the menu tree if the } { program is an application or registers it in the accessory } { menu. } { ------------------------------------------------------------ } constructor TMenu.Init( tree : TResource ); begin TReceiver.Init; if appFlag then begin menuTree := tree; menu_bar( menuTree, 1 ); end end; { ------------------------------------------------------------ } { the destructor removes menu tree if the program is an } { application. } { ------------------------------------------------------------ } destructor TMenu.Done; begin if appFlag then menu_bar( menuTree, 0 ); TReceiver.Done; end; { ------------------------------------------------------------ } { the descandants of the generic menu object will use the } { method TMenu.MenuHandleItem to react on the selection of } { menu items. } { ------------------------------------------------------------ } procedure TMenu.MenuHandleItem( item : Integer ); begin end; { ------------------------------------------------------------ } { the method TMenu.KeyPressedMessage calls the KeyPressed } { method, which reacts an key strokes, if the program is an } { application. } { ------------------------------------------------------------ } procedure TMenu.KeyPressedMessage( keycode : Integer ); begin if appFlag then KeyPressed( keycode ) else TReceiver.KeyPressedMessage( keycode ); end; { ------------------------------------------------------------ } { the method TMenu.MenuSelectedMessage calls the } { MenuHandleItem method which handles the selection of the } { menu items. } { ------------------------------------------------------------ } procedure TMenu.MenuSelectedMessage( title, item : Integer ); begin menu_tnormal( menuTree, title, 0 ); MenuHandleItem( item ); menu_tnormal( menuTree, title, 1 ); end; { ------------------------------------------------------------ } { the default is to ignore key strokes. therefore the method } { TMenu.KeyPressed passes key strokes to the next receiver. } { descendants of TMenu may override this method. } { ------------------------------------------------------------ } procedure TMenu.KeyPressed( keycode : Integer ); begin TReceiver.KeyPressedMessage( keycode ); end; end. { ============================================================ } { --- This unit makes lists of files and directories --- } { --- (c) 1992 Pure Software GmbH. --- } UNIT DirSearch; INTERFACE USES Dos; TYPE FileList = ^FileListItem; FileListItem = RECORD next: FileList; time: LongInt; size: LongInt; name: STRING[12]; END; DirList = ^DirListItem; DirListItem = RECORD next: DirList; time: LongInt; name: DirStr; END; FUNCTION ReadDir(dir: DirStr; pat: STRING): FileList; FUNCTION ReadTree(baseDir: DirStr): DirList; PROCEDURE DisposeDir(fList: FileList); PROCEDURE DisposeTree(dList: DirList); IMPLEMENTATION { --- Make a list of files matching pat --- } FUNCTION ReadDir(dir: DirStr; pat: STRING): FileList; VAR fileRec : SearchRec; fList, newFile: FileList; BEGIN fList := nil; FindFirst( dir + pat, 0, fileRec ); WHILE DosError = 0 DO BEGIN NEW(newFile); newFile^.next := fList; fList := newFile; newFile^.time := fileRec.time; newFile^.size := fileRec.size; newFile^.name := fileRec.name; FindNext( fileRec ); END; ReadDir := fList; END; { --- Attach list of subdirectories starting at baseDir to dList --- } FUNCTION InsertTree(baseDir: DirStr; dList: DirList): DirList; VAR fileRec : SearchRec; newDir: DirList; BEGIN NEW(newDir); newDir^.next := dList; newDir^.name := baseDir; dList := newDir; FindFirst( baseDir + '*.*', Directory, fileRec ); WHILE DosError = 0 DO BEGIN IF (fileRec.attr = Directory) AND (fileRec.name[1] <> '.') THEN dList := InsertTree(baseDir + fileRec.name + '\', dList); FindNext( fileRec ); END; InsertTree := dList; END; { --- Make a list of subdirectories starting at baseDir --- } FUNCTION ReadTree(baseDir: DirStr): DirList; BEGIN IF baseDir[LENGTH(baseDir)] <> '\' THEN baseDir := baseDir + '\'; ReadTree := InsertTree(baseDir, NIL); END; { --- Throw away list of files --- } PROCEDURE DisposeDir(fList: FileList); VAR f: FileList; BEGIN WHILE fList <> NIL DO BEGIN f := fList; fList := f^.next; DISPOSE(f); END; END; { --- Throw away tree of directories --- } PROCEDURE DisposeTree(dList: DirList); VAR d: DirList; BEGIN WHILE dList <> NIL DO BEGIN d := dList; dList := d^.next; DISPOSE(d); END; END; END. { --- This unit provides fast string search routines --- } { --- (c) 1992 Pure Software GmbH. --- } {$R- Range tests would be somewhat silly here... } { See declaration of TextIndex. } UNIT StrSearch; INTERFACE TYPE TextIndex = 0..2000000000; CharArray = ARRAY [TextIndex] OF CHAR; CharArrayP = ^CharArray; CharMap = ARRAY [CHAR] OF CHAR; FUNCTION BMSearch(pat: STRING; startPos, endPos: TextIndex; VAR text: CharArray) : TextIndex; FUNCTION BMSearchMap(pat: STRING; startPos, endPos: TextIndex; VAR text: CharArray; VAR chMap: CharMap) : TextIndex; IMPLEMENTATION { --- This is the fast Boyer-Moore string search --- } { --- Adapted from : N. Wirth, Algorithmen und --- } { --- Datenstrukturen mit Modula-2, p. 69 --- } FUNCTION BMSearch(pat: STRING; startPos, endPos: TextIndex; VAR text: CharArray) : TextIndex; VAR i, k: TextIndex; j: INTEGER; ch: CHAR; d: ARRAY [CHAR] OF INTEGER; BEGIN FOR ch := #0 TO #255 DO d[ch] := LENGTH(pat); FOR j := 1 TO LENGTH(pat)-1 DO d[ pat[j] ] := LENGTH(pat)-j; i := startPos + LENGTH(pat); endPos := endPos + LENGTH(pat); REPEAT j := LENGTH(pat); k := i; REPEAT k := k - 1; j := j - 1; UNTIL (j < 0) OR (pat[j+1] <> text[k]); i := i + d[text[i-1]]; UNTIL (j < 0) OR (i >= endPos); BMSearch := i - LENGTH(pat); END; { --- This is a variant of the string search useful --- } { --- for case insensitive and whole word searches. --- } { --- Before comparing, chars are mapped by a table --- } FUNCTION BMSearchMap(pat: STRING; startPos, endPos: TextIndex; VAR text: CharArray; VAR chMap: CharMap) : TextIndex; VAR i, k: TextIndex; j: INTEGER; ch: CHAR; d: ARRAY [CHAR] OF INTEGER; BEGIN { Map the whole pattern } FOR j := 1 TO LENGTH(pat) DO pat[j] := chMap[ pat[j] ]; FOR ch := #0 TO #255 DO d[ch] := LENGTH(pat); FOR j := 1 TO LENGTH(pat)-1 DO d[ pat[j] ] := LENGTH(pat)-j; i := startPos + LENGTH(pat); endPos := endPos + LENGTH(pat); REPEAT j := LENGTH(pat); k := i; REPEAT k := k - 1; j := j - 1; UNTIL (j < 0) OR (pat[j+1] <> chMap[text[k]]); i := i + d[ chMap[ text[i-1] ] ]; UNTIL (j < 0) OR (i >= endPos); BMSearchMap := i - LENGTH(pat); END; END. { --- A Program to find strings in (multiple) files. --- } { --- Similar to unix grep or Norton find. --- } { --- (c) 1992 Pure Software GmbH. --- } {$E .TTP} { This program takes parameters } PROGRAM Find; USES StrSearch, DirSearch, Dos; CONST carriageReturn = #13; lineFeed = #10; VAR options: SET OF CHAR; { set of option chars on command line } chMap: CharMap; { character map table for case insensitive } { and whole word search options } { --- Tell people how to use this program --- } PROCEDURE Usage; BEGIN WRITELN('Usage: FIND [options] pattern filename {filename}'); WRITELN; WRITELN('-C Only print count of matching lines'); WRITELN('-D Search subdirectories'); WRITELN('-I Case insensitive search'); WRITELN('-L Only list file names'); WRITELN('-W Match whole words'); WRITELN; WRITELN('Example: FIND -DIW I PP\*.PAS'); WRITELN('this finds identifier i in all pascal files'); WRITELN('in directory PP and its subdirectories.'); END; { --- Abort execution with an error message --- } PROCEDURE Fatal(msg: STRING); BEGIN WRITELN(msg); HALT(1); END; { --- Allocate enough space and read whole file into memory --- } FUNCTION LoadFile(fileName: STRING; VAR size: TextIndex) : CharArrayP; VAR textP : CharArrayP; inFile : FILE OF CHAR; inSize, readSize: TextIndex; BEGIN {$I-} ASSIGN(inFile, fileName); RESET(inFile); IF IOResult <> 0 THEN Fatal('File not found: ' + fileName); inSize := FileSize(inFile); { To simplify later processing, dummy line ends } { are inserted at the beginning and end of the file } GETMEM(textP, 2 + inSize + 2); textP^[0] := carriageReturn; textP^[1] := lineFeed; BLOCKREAD(inFile, textP^[2], inSize, readSize); IF (IOResult <> 0) OR (insize <> readSize) THEN Fatal('Read error on: ' + fileName); textP^[inSize+2] := carriageReturn; textP^[inSize+3] := lineFeed; CLOSE(inFile); IF IOResult <> 0 THEN Fatal('Close error on: ' + fileName); LoadFile := textP; size := readSize + 4; END; { --- Copy line containing pos into a string --- } FUNCTION GetLine(pos: TextIndex; VAR text: CharArray) : STRING; VAR startPos, endPos: TextIndex; len: INTEGER; BEGIN startPos := pos; endPos := pos; WHILE text[startPos-1] <> lineFeed DO startPos := startPos - 1; WHILE text[endPos] <> carriageReturn DO endPos := endPos + 1; IF endPos > startPos + 255 THEN endPos := startPos + 255; len := 0; WHILE startPos < endPos DO BEGIN len := len + 1; GetLine[len] := text[startPos]; startPos := startPos + 1; END; GetLine[0] := CHR(len); END; { --- Count number of lines between startPos and endPos --- } FUNCTION LineCnt(startPos, endPos: TextIndex; VAR text: CharArray): LONGINT; VAR cnt: LONGINT; BEGIN cnt := 0; WHILE startPos < endPos DO BEGIN IF text[startPos] = carriageReturn THEN cnt := cnt + 1; startPos := startPos + 1; END; LineCnt := cnt; END; { --- Initialize the character map table --- } PROCEDURE InitCharMap(VAR chMap: CharMap); CONST wordChars = ['0'..'9', 'A'..'Z', 'a'..'z', '_', '', '', '', '', '', '']; VAR c: CHAR; BEGIN FOR c := #0 TO #255 DO { Default: identity map } chMap[c] := c; IF 'I' IN options THEN { Map lower to upper case } FOR c := #0 TO #255 DO chMap[c] := UpCase(c); IF 'W' IN options THEN { Map non word chars to #0 } FOR c := #0 TO #255 DO IF NOT (c IN wordChars) THEN chMap[c] := #0; END; { --- Search file for pattern --- } PROCEDURE GrepFile(pattern, fileName: STRING; VAR chMap: CharMap); VAR textP : CharArrayP; searchStart, searchRes, searchEnd : TextIndex; inSize : TextIndex; matchCnt: LONGINT; lineNum, lCnt: LONGINT; BEGIN textP := LoadFile(fileName, inSize); searchStart := 1; lineNum := 1; searchEnd := inSize - LENGTH(pattern); searchRes := BMSearchMap(pattern, searchStart, searchEnd, textP^, chMap); IF 'C' IN options THEN BEGIN matchCnt := 0; WHILE searchRes < searchEnd DO BEGIN matchCnt := matchCnt + 1; searchStart := searchRes + 1; searchRes := BMSearchMap(pattern, searchStart, searchEnd, textP^, chMap); END; WRITELN(fileName, ' : ', matchCnt); END ELSE BEGIN IF searchRes < searchEnd THEN BEGIN WRITELN(fileName); IF NOT ('L' IN options) THEN REPEAT lCnt := LineCnt(searchStart, searchRes, textP^); IF lCnt <> 0 THEN BEGIN lineNum := lineNum + lCnt; WRITELN(lineNum:4, '| ', GetLine(searchRes, textP^) ); END; searchStart := searchRes + 1; searchRes := BMSearchMap(pattern, searchStart, searchEnd, textP^, chMap); UNTIL searchRes >= searchEnd; END; END; FreeMem(textP, inSize); END; { --- Search files described by fileName for pattern --- } PROCEDURE GrepFiles(pattern, fileName: STRING; VAR chMap: CharMap); VAR matchingFiles, f : FileList; dir: DirStr; name: NameStr; ext: ExtStr; d, dList: DirList; BEGIN { Build list of directories to search } FSplit(fileName, dir, name, ext); fileName := name + ext; IF 'D' IN options THEN dList := ReadTree(dir) ELSE BEGIN NEW(dList); dList^.next := NIL; dList^.name := dir; END; { Search matching files in list of directories } d := dList; WHILE d <> NIL DO BEGIN matchingFiles := ReadDir(d^.name, fileName); f := matchingFiles; WHILE f <> NIL DO BEGIN GrepFile(pattern, d^.name + f^.name, chMap); f := f^.next; END; DisposeDir(matchingFiles); d := d^.next; END; DisposeTree(dList); END; CONST validOptions = ['C', 'D', 'I', 'L', 'W']; VAR parInx: WORD; i: INTEGER; optChar: CHAR; parStr, pattern: STRING; BEGIN { Call with no parameters gives usage info } IF ParamCount < 2 THEN BEGIN Usage; HALT; END; { First, check all command line parameters for options } options := []; FOR parInx := 1 TO ParamCount DO BEGIN parStr := ParamStr(parInx); IF parStr[1] = '-' THEN BEGIN FOR i := 2 TO LENGTH(parStr) DO BEGIN optChar := UpCase(parStr[i]); IF optChar IN validOptions THEN options := options + [optChar] ELSE Fatal('Invalid option: ' + optChar); END; END; END; { Of the non-option parameters, the first one is the pattern, the rest are filenames } pattern := ''; FOR parInx := 1 TO ParamCount DO BEGIN parStr := ParamStr(parInx); IF parStr[1] <> '-' THEN BEGIN IF pattern <> '' THEN GrepFiles(pattern, parStr, chMap) ELSE BEGIN pattern := parStr; IF pattern = '' THEN Fatal('Pattern is empty') ELSE BEGIN InitCharMap(chMap); IF 'W' IN options THEN pattern := ' ' + pattern + ' '; END; END; END; END; END. 4hhhh $3 4$\L -hz!      %  '  4 P    l 1 6'A ]-'#    $  ( 7 >B  J M  O  Q S 0UY(L ]hi jw   * > P Q R \ n  x    Das Disk JutilityOrdner anlegenWhle die gewnschte Funktion ausDatei-InfoAUSGANGHilfeDatei lschenMini-RechnerFreier SpeicherO KNur LesenAttribut:Datum:Uhrzeit:Lesen/SchreibenDas Jutility, Version 1.0(C) 1992 by Oliver BuchmannIm Accessorybetrieb fr Signum!Drei geeignet,um Dateien zu lschen, Ordner anzulegenDateiinformationen zu bekommen oderTOLL!Dateien umzubenennen.natrlich mit Pure Pascal entwickeltApplication Systems HeidelbergRechneANDAusgangOR+-*/DIVMODDatei-Info____________Dateinname: ____________xxxxxxxxxxxx Lnge: Mini-Rechner0000000000000000000Ergebnis : ___________________xxxxxxxxxxxxxxxxxxxVerknpfungsform:000000000Zahl 1: _________xxxxxxxxx000000000Zahl 2: _________xxxxxxxxx00Stellen : __99n+l^-CEc$vݿanOmգG)#>|th(]m}]l #V `΍/%*T䷤d7L-VVznh\>gJK-|M@5+nh0>z5uYc2sš0:LQ <RFzj uV 4 ^gGCM ۴7d5Ͽ:th*F"hPWZiK,*Ud =!4%(E&lpZMn. y_O+16EɁĮ M 8[0 Ї# XQc3_(]rעbS n#W@ vy 3ilТf\ K֐8s^} Q14gb|;g넾.d -F;V1A@qvZpbwBrqs+!Evn)!䚬%VpaE Hzӑ$iZO4M'Yiď͇"FORM1F_CREATED_INFOEXIT1INFODELETECALC FREERAMFORM2FNAMEF_LENEXIT2LAENGEONLY_R F_DATE F_TIME R_AND_WFORM3EXIT3FORM4RECHNEAND_ENEXIT4RESULTOR_ENPLUS MINUS MAL GETEILT ZAHL1ZAHL2DIV_ENMOD_ENDEZISgC\VL{gX u8ׁ)kFuƆF8}HW_h%#.hLك}_ϰ/!|lTu5`Yll9x -1 THEN appl_exit; {$X-} (* alte EXIT-Prozedur *) EXITPROC := OldProc END; (* Initialisierungsfunktion *) FUNCTION InitApp : BOOLEAN; (* Typisierte Konstanten *) CONST (* Fensterelemente *) WindowElements : INTEGER = NAME OR CLOSER OR MOVER; BEGIN (* EXIT-Prozedur anmelden *) OldProc := EXITPROC; EXITPROC := @AppExitProc; (* Anmeldung bei den AES *) appl_id := appl_init; IF appl_id < 0 THEN BEGIN appl_id := -1; InitApp := FALSE; EXIT END; (* Resourcen initialisieren und vorbereiten *) MyResource := InitResourcePool(@CalcRsc); RechnerObjTree := GetResource(MyResource, RECHNER); AboutObjTree := GetResource(MyResource, COPYRGHT); SetPtext(RechnerObjTree, TANZEIGE, '0'); (* Instanz MyCalc initialisieren *) MyCalc.Init; (* Instanz MyWindow vorbereiten *) MyWindow.SetTree(RechnerObjTree); MyWindow.SetElements(WindowElements); (* Applikation- bzw. Accessory-spezifische Vorbereitungen *) {$X+} IF AppFlag THEN BEGIN (* Fenster ffnen *) IF NOT(MyWindow.OpenWindow(WinName)) THEN BEGIN InitApp := FALSE; EXIT END; (* Mauszeiger als Pfeil *) graf_mouse(ARROW, MFORMPtr(0)); END ELSE BEGIN (* Meneintrag *) menu_id := menu_register(appl_id, AccName); (* Kein Eintrag erfolgt? *) IF menu_id < 0 THEN BEGIN InitApp := FALSE; EXIT END END; {$X-} (* Initialisierung OK! *) InitApp := TRUE END; (* Programmverlauf *) PROCEDURE DoApp; (* Konstanten *) CONST (* Informationstaste *) KeyInfo = '?'; VAR Evnt : INTEGER; (* Event *) Msg : ARRAY_8; (* Messages *) Mmox, Mmoy, (* fr Events *) Mmobutton, Mmokstate, Mkreturn, Mbreturn : INTEGER; (* Reaktion auf Mausereignis *) {$X+} PROCEDURE DoButton(VAR Evnt : INTEGER; Mx, My : INTEGER; VAR Mkey : INTEGER); (* Konstanten *) CONST (* Tabelleneintrge fr bersetzung Objekttyp in Taste *) MaxTab = 21; (* Typen *) TYPE ObjRecord = RECORD obj : INTEGER; (* Objektnummer *) key : CHAR (* Taste *) END; (* Typisierte Konstanten *) CONST (* Tabelle Objekttyp und dazugehrige Taste *) ObjTabelle : ARRAY [0..MaxTab] OF ObjRecord = ( (obj : TCM; key : KeyClearMemory), (obj : TM; key : KeyMemory), (obj : TRM; key : KeyReMemory), (obj : TSM; key : KeySwitchMemory), (obj : TCLEAR; key : KeyClear), (obj : TINFO; key : KeyInfo), (obj : TDIV; key : KeyDiv), (obj : TMUL; key : KeyMul), (obj : TSUB; key : KeySub), (obj : TADD; key : KeyAdd), (obj : TENTER; key : KeyEnter), (obj : TSIGN; key : KeyChangeSign), (obj : T0; key : Key0), (obj : T1; key : Key1), (obj : T2; key : Key2), (obj : T3; key : Key3), (obj : T4; key : Key4), (obj : T5; key : Key5), (obj : T6; key : Key6), (obj : T7; key : Key7), (obj : T8; key : Key8), (obj : T9; key : Key9) ); (* Variablen *) VAR i, dummy, obj : INTEGER; BEGIN (* Objekt unter Mausposition *) obj := objc_find(RechnerObjTree, ROOT, MAX_DEPTH, Mx, My); (* Objekt gefunden? *) IF obj <> -1 THEN BEGIN (* Tabelle nach quivalenter Taste untersuchen *) FOR i:=0 TO MaxTab DO BEGIN (* Objekt gefunden? *) IF ObjTabelle[i].obj = obj THEN BEGIN (* Tastaturereignis hinzufgen *) Evnt := Evnt OR MU_KEYBD; (* Taste setzen *) Mkey := ORD(ObjTabelle[i].key); (* Warten, bis Maustaste losgelasen *) Evnt_button(0, $1, $0, dummy, dummy, dummy, dummy) END END END END; {$X-} (* Reaktion auf Message-Ereignis *) FUNCTION DoMesag(Msg : ARRAY_8) : BOOLEAN; BEGIN (* Was fr eine Nachricht? *) CASE Msg[0] OF (* Accessory geffnet? *) AC_OPEN : {$X+} MyWindow.OpenWindow(WinName); {$X-} (* Accessory geschlossen? *) AC_CLOSE : MyWindow.CloseWindow(FALSE); (* Fenster nach oben? *) WM_TOPPED: IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Top; (* Fenster geschlossen? *) WM_CLOSED : (* Wenn Programm, dann verlassen. *) (* Sonst nur Fenster schlieen. *) IF AppFlag THEN BEGIN IF MyWindow.IsHandle(Msg[3]) THEN BEGIN DoMesag := TRUE; EXIT END END ELSE MyWindow.CloseWindow(TRUE); (* Fenster bewegt? *) WM_MOVED : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Move(Msg[4], Msg[5]); (* Fenster(teil)bereich neu zeichnen? *) WM_REDRAW : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Draw(Msg[4], Msg[5], Msg[6], Msg[7]) END; DoMesag := FALSE END; (* Reaktion auf Tastatur-Ereignis *) PROCEDURE DoKeybd(MKey : INTEGER); (* Konstanten *) CONST (* Texte fr Alertboxen *) ErrOverFlow = 'Der Wertebereich|wurde berschritten!'; ErrDivisionBy0 = 'Durch 0 kann|nicht geteilt|werden!'; (* Variablen *) VAR c : CHAR; (* fr Tastatureingaben *) anzstr : STRING; (* Anzeige *) x, y : INTEGER; (* zur Anzeigeaktualisierung *) (* Informationsdialog ausgeben und verwalten *) {$X+} PROCEDURE DoInfo; (* Variablen *) VAR x, y, w, h : INTEGER; BEGIN (* Eingaben/Aktualisierungen sperren *) wind_update(BEG_UPDATE); (* Dialogbox zentrieren *) form_center(AboutObjTree, x, y, w, h); (* Hintergrund reservieren *) form_dial(FMD_START, x, y, w, h, x, y, w, h); (* Dialogbox ausgeben *) objc_draw(AboutObjTree, ROOT, MAX_DEPTH, x, y, w, h); (* Dialog verwalten *) form_do(AboutObjTree, ROOT); (* Status SELECTED zurcksetzen *) AboutObjTree^[BOK].ob_state := AboutObjTree^[BOK].ob_state AND NOT(SELECTED); (* Hintergrund freigeben *) form_dial(FMD_FINISH, x, y, w, h, x, y, w, h); (* Aktualisierungen wieder zulassen *) wind_update(END_UPDATE) END; {$X-} (* Tastatureingaben falls ntig bersetzen *) FUNCTION Translate(key : INTEGER) : CHAR; (* Variablen *) VAR scanKey, asciiKey : CHAR; BEGIN (* Lowbyte = ASCII-Code *) asciiKey := CHR(LO(key)); (* Highbyte = Scan-Code *) scanKey := CHR(HI(key)); (* Erst den Scan-Code untersuchen *) CASE ORD(scankey) OF 71 : Translate := KeyClear; (* ClrHome *) 97 : Translate := KeyClear; (* Undo *) 98 : Translate := KeyInfo; (* Help *) ELSE (* Dann den ASCII-Code untersuchen *) CASE ORD(asciikey) OF 8 : Translate := KeyClear; (* Backspace *) 127 : Translate := KeyClear; (* Delete *) 61 : Translate := KeyEnter (* '=' *) (* Sonst gibt es nichts zu ndern *) ELSE Translate := asciiKey END END END; BEGIN (* Eingabe auswerten *) c := Translate(Mkey); (* Information gewnscht? *) (* Wenn ja, dann ausgeben. Sonst rechnen! *) IF c = KeyInfo THEN DoInfo ELSE BEGIN (* Eingabeauswertung *) IF MyCalc.Input(c) THEN BEGIN (* Fehler aufgetreten? *) {$X+} CASE MyCalc.IsError OF (* berlauf? *) Overflow : form_alert(1, BadAlert(ErrOverFlow)); (* Division durch 0? *) DivisionBy0 : form_alert(1, BadAlert(ErrDivisionBy0)); END; {$X-} (* Ergebnis in Zeichenkette umwandeln *) STR(MyCalc.Result, anzstr); (* Anzeige neu setzen *) SetPtext(RechnerObjTree, TANZEIGE, anzstr); (* Offset bestimmen *) {$X+} objc_offset(RechnerObjTree, TANZEIGE, x, y); {$X-} (* Anzeige aktualisieren *) MyWindow.Draw(x, y, RechnerObjTree^[TANZEIGE].ob_width, RechnerObjTree^[TANZEIGE].ob_height) END END END; BEGIN (* Endlosschleife *) WHILE TRUE DO BEGIN (* Ereignis (Message, Maus oder Tastatur) abwarten *) Evnt := evnt_multi(MU_MESAG OR MU_BUTTON OR MU_KEYBD, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, Msg, 0, 0, Mmox, Mmoy, Mmobutton, Mmokstate, Mkreturn, Mbreturn); (* Maustaste gedrckt? *) IF (Evnt AND MU_BUTTON) = MU_BUTTON THEN DoButton(Evnt, Mmox, Mmoy, Mkreturn); (* Message angekommen? *) IF (Evnt AND MU_MESAG) = MU_MESAG THEN IF DoMesag(Msg) THEN EXIT; (* Taste gedrckt? *) IF (Evnt AND MU_KEYBD) = MU_KEYBD THEN DoKeybd(Mkreturn) END END; (* Hauptprogramm *) BEGIN (* Wenn Initialisierung nicht in Ordnung, dann Ende. *) IF NOT(InitApp) THEN EXIT; (* Programmablauf *) DoApp END. ?&A;qT ?I2EE;sh#R ʚjaRZ2s=o}?Y "R~ȿtUF K" |#Xܜ1Г5!pe .AT-, :A6cW,y0a"q`!BЄ,OV`W7#r.*bNdOzjMwefaJ8'Q`o9`qVF.j~~x Jr7HD҆5!p`XHR E*3UX)t~(jӪs1Nd޴(m Vu6xMPyAhs>DHǶԧ̚un%kXsP.ܟLka.yv5#ď ɺB!\ny nj<ɩG~:٣VSweetie 13. 6. 1992 Copyright (c) 1992 by Application Systems /// Heidelberg Software GmbH. Alle Rechte vorbehalten. Sweetie ist ein kleiner Desktoprechner. Er kann mit ganzen Zahlen umgehen und verfgt ber die vier Grundrechenarten. Auerdem kann mit Hilfe eines kleinen Speichers ein Wert vorbergehend gesichert werden. Die Tastaturbelegung folgt dem Zehnerblock auf der Tastatur, wichtige Funktionen sind auch ber andere Tasten erreichbar. So kann auch mit Hilfe von Undo oder ClrHome gelscht werden. Das Gleichheitszeichen hat die gleiche Funktion wie Enter und Help die gleiche wie das Fragezeichen. Der Betrieb von Sweetie erfolgt als Accessory oder Programm, wobei der Programmbetrieb in erster Linie bei einem Multitasking-System interessant ist. @V| Jd\J8-1S[TgJ1Vj C "(("Z8e`goOtyUV5?i։g tJIFgqFTKntq6J uʠ&d;]( <#-9v Kt30el'-cM5i?lfԞ=o"?|'I,N-,Sշ8C8:mBA#QllDX[|@O|* l 5Q3A¹[ ĥESB/aLJЗ}Н'4+aD95Q*LrP:&vgUCy3 '34e0%8@n@ϩ-~.wRECHNERTANZEIGETCMTMTRMTSMTCLEARTINFO TDIV TMUL T7 T8 T9TSUBT4T5T6TADDT1T2T3TENTERT0TSIGNCOPYRGHTBOK{Xc._VZI9,of({6B$3|߈ *XU*r#geWzlq~qSҠpYpҵogJw(Y&t֗Yr.#u͝|-t/x˻2|br#OL[1i҈( !LI&mHIֲ{x ̤Jfp'Te$XhTMܸ hiDʵ%&>  x4t>Wc') IW6=EV_}{Hl e/wk+#hE+= y$?a83 ֻضq|wDQCe?o7xNglRqX~=|-'Xo.N: yjE|jWp+w,Mkⴁ:Rcnŧ%q7]׍+$>/'hL2v>No, uo]_= `eoKg/1oeUS(* Resource Datei Indizes fr CALCRSC *) CONST RECHNER = 0; (* Formular/Dialog *) TANZEIGE = 1; (* BOXTEXT in Baum RECHNER *) TCM = 3; (* BOXTEXT in Baum RECHNER *) TM = 4; (* BOXTEXT in Baum RECHNER *) TRM = 5; (* BOXTEXT in Baum RECHNER *) TSM = 6; (* BOXTEXT in Baum RECHNER *) TCLEAR = 7; (* BOXCHAR in Baum RECHNER *) TINFO = 8; (* BOXCHAR in Baum RECHNER *) TDIV = 9; (* BOXCHAR in Baum RECHNER *) TMUL = 10; (* BOXCHAR in Baum RECHNER *) T7 = 11; (* BOXCHAR in Baum RECHNER *) T8 = 12; (* BOXCHAR in Baum RECHNER *) T9 = 13; (* BOXCHAR in Baum RECHNER *) TSUB = 14; (* BOXCHAR in Baum RECHNER *) T4 = 15; (* BOXCHAR in Baum RECHNER *) T5 = 16; (* BOXCHAR in Baum RECHNER *) T6 = 17; (* BOXCHAR in Baum RECHNER *) TADD = 18; (* BOXCHAR in Baum RECHNER *) T1 = 19; (* BOXCHAR in Baum RECHNER *) T2 = 20; (* BOXCHAR in Baum RECHNER *) T3 = 21; (* BOXCHAR in Baum RECHNER *) TENTER = 22; (* BOXCHAR in Baum RECHNER *) T0 = 23; (* BOXCHAR in Baum RECHNER *) TSIGN = 24; (* BOXCHAR in Baum RECHNER *) COPYRGHT = 1; (* Formular/Dialog *) BOK = 14; (* BUTTON in Baum COPYRGHT *) #P6@$(P GBA(O~Ԍ}$p"^HDm_%Fz6g8ALJ'0EBS!" o$;:N9ٲJ GAMw,)Gнf0e&12WAcR-!$ vJ7J (tV-GC&]r0f LU NBpF#&n=?>2v$חv=0˒-fKzbBqGes}qs\@JՇ"3F F36u%T}H?AmՇmk&-fr75F3;'ǧc̵LJ>N2zm5PQ v}v<Vp2HRC,$(, 00$0@ 0\0C 0? 0/  0* 07 0809 0-040506 0+010203 0=00  0 $ D$x              < X  t  '     !"234HIJ`abxyzOK0123456789CMMRMSMSweetieCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.!s+IZSKpkzVtPoc[>\=&]3MV4*N ?^1)pN}k=8^0&@\gry "pQG'/pyn=[gU0$|Y@Rqj\sUn[q1hALf>iY,1 n)C~/hmu,컀_r_zS{= [P:Aھ_=_iްw'[_!^RECHNERTANZEIGETCMTMTRMTSMTCLEARTINFO TDIV TMUL T7 T8 T9TSUBT4T5T6TADDT1T2T3TENTERT0TSIGNCOPYRGHTBOKy0aچzp3׸Kz[=fc *YׄA ℍ% 7ڢ%łz4.3eH>ߛ:2R[[%~@?hJyǛiq)l1767b}'rMΌ5HK^n~f扎l^^VlIz<Da̕O9iy W MYBU?'< Sz/wkmv@O{Q 嗍}hW6E=9W>/UMޓJ}~ʥJ1T》}~΄+V 9Y}A2;LMY.½Oס ?.ޥtkKQ>MӉFREEMEMTMEMCOPYRGHTBOK?Q{2Y#O4J%ı>6BU̐IiWڛ7Hy/Ρ1wlH,jZo:&aR U^Rv/5عx \rgfۻkM}dbN޷]#PW Wh9YmՅJ`Q6\WPX SX_p/k"AX0 Ub?s`BGS˦]dzpj+bFˤ=!v9bŏA];Mhxă)WḅcJ%-GLhy7:\[S +_./1>Vg7|%5Q^jLOMUϥo"ԩQ-l*GDmZ P<7݇DA W&HQ^߅ݙ/h(럊 S )xF;wyU`<2RHzK bΌ8ꌫ'U̞@Ϡiɐ2,ѓš.=åwf0LO#76uc0ClvZ< kas/ҦnMm;!`,%$tl$_X/v y`>k q; ]+ 9Lb%W69v<~ \9꒰ΊLKYIX¿ Ib@a:\uJfR,K%,,/GEذ`ʖoKIsx^rV!nx6:O򣩜 5!Wsl rg۟a3c4O}٥+T[^{_n_q5Jbh-R04qc[x7hk ^ •r4rp(Y?j>@pD57NU% }H<<67Ϩ[F;ڷѷ:u"HctE~prGe{TQzj[;8e]N@,$ ҨA1J@L[$aَl?).+Yzq~'\\ lgQb#gg=x>xAodOh F\qo}tp/u ^Nʚ>yLո4xU.l3q[Yݕ PXw:< I ~LXmY>8>> 5PNٹe2㨳 BfX|&H؟+mx6.X<{=By.]%HL"/&9ip5j؛8ֲ+Pڶx !Soΐ,Olpb᳇J3-8f+Ⱦl7\f.c[1P\+SYF2s.k-aG_`uo§A($.-4T4MJBFS/sC;:av͝Fx bTlf3ݽ<]kLTja:ꒌFqM63p"Z<~WW|%WqZ=__Da8n'8Vz{+G}F7mVMiMČ4[qژ{4ר_ 0!DčJawZ8G<Ѣ͍%k\{y\dśC0ڎ= V2֕iY92$h!5)cFP,lp؋CިP^Oq-JI;{[ڿ--+ $?] ⮖HIO!bI?cbafGuO%et7oڕSd4Kaf!`x_NX-,&8NL~#kpƷTB5m~c~mr9n\^<=|O? 1ÞIJv7=KK*'m|[[Z94L]|V2Bق@$vck}dHS{nP)ڽ#3qd훼>ݛ H3y僒o>j*uDDMCG* _ xw;ffedkT5ǍHRk}'VCgJ@p%~F1*ＵAҪ{9~W)4>|p ;;B8W%x/Y}+|_GQ;<}ԣ7S,;Vh1^vA=C[;)1k2萍S[Bm.o,dM=[_Hx(~,..$ .,\ $ D$      4 P  l         '   '()123GHIhijyz{ +,OK1234567890 ByteFreeMemCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.vρne휔ZE~+YZuMi& /~ЍP~/-U#2JYgh@鮯oB|F⬩"Nm#n)J J#ǘ`w:}5݈P>-v7"~b-;MHW9ޗZ4r~N|w 5|qпA0@2t%J4٭F>ZИM=ܾa:K\,PH Qϛy Й|*XJU+yX7!*&Ӆ,8J{d&O-uT 6 k+iוnm5b+T յZv2.|#cy(L+g" Co,ayVw1Fy{*#ʶLˏ&aɣN._Zml_'R{eAM UN8mzQl<Ĺ/ue?6_)n^GoF(,=3ʂ!O3i;BÙN2f_vıP}IsNxYL+aeoj5M ݥwHN-b(@H{Hx?"TBBMZ02X͙2o+XVgSr.L[эi.!m5+DU] Rg9^N2M Y3dO_~zqqG7r+#O?t<9iK,p+*Ԓ+Wڄ,s^LSRt+B:?d % _0i¤]#ퟏL"\i0dVn'b_e 2M;r>e %` $T.'rc/Z΍8'|h^:mOR2~mfϲyFREEMEMTMEMCOPYRGHTBOK M:ȨBz]&dٲWeuz긘G'%4)[Ħ r"S*l_6ZM$\T?{e-q}jȵs^ڑҳ;Råu*FD9JwWf &sNºm9؜9^Ju]LM4gU(.-(yӪ["4bI\ dnJG[賭]9SzxoJXPxhJ ~~WzɠtīS֨o7~psy@Wgس ![}qq\*LJGVSZR|JjdʃKĂ{8hK#H=j7wOfS67Hu(xj5jVY$WG5岤WEy ׵콜m?i픏ke(&[*;wO|{#*3FT>.A8-ٮpT۠}$n{0 Q*өJ]͆Y,KDM6e{{d"Wyc ;jԐ`#&*R##&NX ---------------- Pure Pascal for Atari STe/TT Version 1.0 (c) 1992 Pure Software GmbH ----------------3C,`BC.N yC. fJC6gaFa yC2N Runtime error at offset $0123456789ABCDEFHP?< NA\ONuOAa09C,r Oa OpB0a&yEJ g.Aa&9C68<|;??<NAXOQ?<NAO Nur&H fr&oEC* + Ым*@Ы,UC#CB"k" <*AYM#E.M// ?<?<JNAO #Epr+g|<fB k, AfE"H gJ"gJfJf`VARGV=XOA$H`JgBR@JfHR$H`A"HB0< c<"frJg "f`B(R@HQ"HJf*3EJ9EgB?< NA\O x"( e,dP dJdDd>d8d2 e2`*e$ eeee e dB9E/?< NA\O#8E#>E#RE#XE#^E#dE#jEa#C2HyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9ENu _0<Nh"yCBb0<Na#C6BgHz?<Ns`?9C,?<LNAJ9Eg~p yEav#Ep yEad#Ep yEaR#Ep yEa@#Ep yEa.#Ep yEa#Ep yEa #ENuH瀠>NMPO @$_Nu!|!| 1|װr!A!A 1A!|HSG!K&_A4<wb0w`Bp42<d0`QNur4d`QNupQNureQNu/ Hx?<HNA\$_UeNu yE"Hp0"iQd0fU?m <?NuH0vHx?<HNA\eր/?<HNA\Jg&` g&S/?<INA\`p yE"H"i0րf L Nu0(|װ|װfHS&H kװg + g "@N3C:RkB+ +g "@ KN3C:&_Nu0(|װ|װfHS&H kװg + g "@N3C:TkB+ +g "@ KN3C:&_Nur?RHHPJl-DC*e")t UЁ E"f  _0`;B@'d 09876543210pJ@k hײe H&H(I6xc`p aQ`aQJyC:f (g "@N3C: KLNuC` rlCAS QSr QNuJyC:fv"( b2(f* (gHP"@N _3C:fNJ f`:"("hgf1` 1R!A<gİ< g(Nup`QBNuJyC:f0"h"(R!A (Se (gHP"@N3C: _NuRHHPJ@l JAg-D@C&Ye2)t AUA 2f"_ Nu'd 09876543210a3C:NuJlD@| |l@0; `p`pNuHRHS&Hp'@'@'@ 0+|ױg$< >'B|ײf2<<`'| '| p`7|ײ2<=J+4gx$+4NULgbAUXgPRNgLPTgCOMgnCONg>'| OA4"O?Ho?afNAOJl a7|װ`6p&_$_Nup kױg$< 'B'B`'| lB`+8<1Sbp`+8<1Ub~p`HSHR&H??<>NAXOJ@f7|װp$_&_Nua~`aP< gpNuHRHP/(/(??<?NAO _$_JkF!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R ADtapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fC:Nu3iC:NuByEByEAp,"@ "A3@@E"`"p"@ " (1B3E"ONu/ Hz?<&NN\O$_NuJEfAEByC,BC.BC6ByC:BC<C@BPC!IC!I#EBEB9CANJyEgCAACFC*NACFNADtCNADtN$Nu2H4H…HB0H@0Nu2|0@A0NuNVH<.K * fD(H&LHnHnACN!TPOp0+Ev8+SDCmJf80Hr,Ah0NAh0.NAh0NvAh0.Nj`60Hr,Ah0N. <.B* ??024N!XO5@0*J@l| `>2|JAgJ.cC AN|JCgJ.c0*C AN:LN^NuNVH *(&$H<.??0*24N!XOJ@l| LxN^Nu0(N!Nu/ $H0*N!5|$_NuNVH8(&$HGIHnHn0*ACrN"PO?.?.?0*r4N"4\OHnHn0*ACrN"PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN"4\ONuNVH<*(&$H<.GIKpN"XHnHnACprN"POHTHS0*ACr N"PO`HnHn?????AC02.4NOJgXHnHn?.?.?.?.?.AC0.2.4.NOJg?.A0.2.4.NnTOHTHS0*ACr N"POJSoJTnXpN"XL\O&N^Nu@m0Nu@n0NuNVH<*I(H.(&&n$n<. :. 02N802N:0G2nN40R0n2nN60SJRoJSnB@`pL\O yGpN yGhZ??????p24N O pN"XL<N^NuNV/&0H@bf/N6XO|C fJ9H gB@`pH &N^NuH*(&UEf.? yGpr4N fTOS@fJ9H gB@`pH L8NuNV/J9C*g=|3`=|HnHnHnHnHnBg?<BgBgBgBgBgBgBgBgBgBg?<AC0.rtNO.60|@f/ANXOJfF0| @ f/NFXO0|S@f /0.NXO|UCf0.2.4.N`R&N^Nu,..$ .,\ $ D$      4 P  l         '   '()123GHIhijyz{ +,OK1234567890 ByteFreeMemCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.JHf$N @N"NN(NJgNNuI"q "QN?/ N$0rYO?HBa\ONu?/ N$0rYO?HBa\ONuCH2"<M0<H0NBL AI80Nup "<`p"<`CH#H|p"<`HQCH0#Hd222"" """"2 Cp"<ar"_2"o2"o"2"o&2"o*2"o.2NuCM?NCH3_#|M|p#"<`"CH0222"2C#H|p*"<`CH02222C#H|p+"<`HQCH3@#H|p,"<a"_2"o2NuCH3@#H|p2"<`CH0222""" Cp3"< `lO"O?N0CH3@#O|p4"<aBONuHQCH#H|p6"<a$"_2"o2"o2"o 2NuHQHPpM"<a"_2"_2"o2"o2NuCH3@#H|pN"<`CH0222"Cpd"<`CH0222"Cpe"<`CH3@pf"<`vCH3@pg"<``HQHPCH3@3Aph"<aB"_2"_2"o2"o2NuCH0222"2Cpi"<`CH3@pk"<`HQHPCH0222" 2Cpl"<a"_2"_2"o 2"o2NuH0JMofhN @AHCMELG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB"x N       rB0B(h0`jVH@    d( h4 .8N,.> v2HD           0  6  2 X  "` (&&0"T 0$>6ק& B>wiSz>%zD#@?$=u9/7WA|#Srц/%$eM:;FqU?Fvވ.~}hu\,ɲ;[+} ts]O"LB.~W LJjyu):PC]sj_gˆFַ&5t$'G` 0 KnJhSZk :a߮sW,W8F˨  !-/YԀMFR8 tq&KuR yR۪^ٽw""Y*PȲn׭0"anHmD 4\fh";ʼO@O\2)^壄i~ո>c/SB%%0ԟQޡ\<(N5A< \@ʜԕi3U4~ 3*R8~@wmhH@+aFg2 ~j5TVGQZ`Oa{.] *V~Ore],Vq##(************************************************************************* FreeMem Copyright (c) 1992 by Application Systems Heidelberg. ======= Alle Rechte vorbehalten. Autor: Dietmar Rabich Programm: FREEMEM.PAS Entwicklungssystem: PurePascal Die Speicheranzeige ist ein kleines Beispielprogramm, welches mit PurePascal entwickelt wurde. Es ist sowohl als Programm als auch als Accessory lauffhig. Wichtig! Vor der bersetzung des Programms mssen die Resourcen mit BINOBJ bersetzt werden. Aufruf: BINOBJ fmrsc.rsc fmrsc FmRsc *************************************************************************) PROGRAM MeineSpeicheranzeige; (* Importierte Units *) (* Gem: Standard-Unit von PurePascal *) (* Resources: Unit zur Verwaltung von eingebundenen Resourcen *) (* OWindows: Unit zur Verwaltung des Objekt-Fensters *) USES Gem, OWindows, Resources; (* Konstanten *) CONST (* Name des Programms *) AppName = 'FreeMem'; WinName = ' ' + AppName + ' '; AccName = ' ' + AppName + '...'; (* Konstanten fr die Resourcen *) {$I FMRSC.I} (* Typen *) TYPE Anzeige = RECORD MemAvail : BOOLEAN; CurrentValue : LONGINT END; (* Variablen *) VAR appl_id, (* Applikation-Identifikation *) menu_id : INTEGER; (* Menidentifikation (ACC) *) MyWindow : ObjWindow; (* Fenster-Objekt *) MemObjTree, (* Objektbaum Anzeige *) AboutObjTree : AESTreePtr; (* Objektbaum About-Dialog *) OldProc : POINTER; (* fr EXIT-Prozedur *) MyResource : TResourcePoolPtr; (* Resourcepointer *) Show, Old : Anzeige; (* Anzeigeform *) (* Resourcen *) PROCEDURE FmRsc; EXTERNAL; {$L FMRSC} (* EXIT-Prozedur *) PROCEDURE AppExitProc; VAR Msg : ARRAY_8; BEGIN (* Fenster schlieen *) MyWindow.CloseWindow(TRUE); (* Resourcen freigeben *) FreeResourcePool(MyResource); (* Wenn Accessory, dann hier verharren *) {$X+} IF NOT(AppFlag) THEN WHILE TRUE DO evnt_mesag(Msg); (* Abmeldung bei den AES *) IF appl_id <> -1 THEN appl_exit; {$X-} (* alte EXIT-Prozedur *) EXITPROC := OldProc END; (* Initialisierungsfunktion *) FUNCTION InitApp : BOOLEAN; (* Typisierte Konstanten *) CONST (* Fensterelemente *) WindowElements : INTEGER = NAME OR CLOSER OR MOVER; (* Variablen *) VAR dummy, CellH : INTEGER; BEGIN (* EXIT-Prozedur anmelden *) OldProc := EXITPROC; EXITPROC := @AppExitProc; (* Anmeldung bei den AES *) appl_id := appl_init; IF appl_id < 0 THEN BEGIN appl_id := -1; InitApp := FALSE; EXIT END; (* Resourcen initialisieren und vorbereiten *) MyResource := InitResourcePool(@FmRsc); MemObjTree := GetResource(MyResource, FREEMEM); AboutObjTree := GetResource(MyResource, COPYRGHT); SetPtext(MemObjTree, TMEM, ''); {$X+} graf_handle(dummy, dummy, dummy, CellH); {$X-} MemObjTree^[ROOT].ob_height := CellH; MemObjTree^[TMEM].ob_height := CellH; (* Instanz MyWindow vorbereiten *) MyWindow.SetTree(MemObjTree); MyWindow.SetElements(WindowElements); (* Applikation- bzw. Accessory-spezifische Vorbereitungen *) {$X+} IF AppFlag THEN BEGIN (* Fenster ffnen *) IF NOT(MyWindow.OpenWindow(WinName)) THEN BEGIN InitApp := FALSE; EXIT END; (* Mauszeiger als Pfeil *) graf_mouse(ARROW, MFORMPtr(0)); END ELSE BEGIN (* Meneintrag *) menu_id := menu_register(appl_id, AccName); (* Kein Eintrag erfolgt? *) IF menu_id < 0 THEN BEGIN InitApp := FALSE; EXIT END END; {$X-} (* Anzeige von MemAvail *) Show.MemAvail := TRUE; Show.CurrentValue := 0; Old := Show; (* Initialisierung OK! *) InitApp := TRUE END; (* Programmverlauf *) PROCEDURE DoApp; VAR Evnt, REvent : INTEGER; (* Event *) Msg : ARRAY_8; (* Messages *) Mmox, Mmoy, (* fr Events *) Mmobutton, Mmokstate, Mkreturn, Mbreturn : INTEGER; (* Reaktion auf Message-Ereignis *) FUNCTION DoMesag(Msg : ARRAY_8) : BOOLEAN; BEGIN (* Was fr eine Nachricht? *) CASE Msg[0] OF (* Accessory geffnet? *) AC_OPEN : BEGIN {$X+} MyWindow.OpenWindow(WinName); {$X-} (* Anzeige des Speicherplatzes *) REvent := REvent OR MU_TIMER END; (* Accessory geschlossen? *) AC_CLOSE : BEGIN (* keine Anzeige mehr *) REvent := REvent AND NOT(MU_TIMER); (* Fenster zu *) MyWindow.CloseWindow(FALSE) END; (* Fenster nach oben? *) WM_TOPPED: IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Top; (* Fenster geschlossen? *) WM_CLOSED : BEGIN (* keine Anzeige mehr *) REvent := REvent AND NOT(MU_TIMER); (* Wenn Programm, dann verlassen. *) (* Sonst nur Fenster schlieen. *) IF AppFlag THEN BEGIN IF MyWindow.IsHandle(Msg[3]) THEN BEGIN DoMesag := TRUE; EXIT END END ELSE MyWindow.CloseWindow(TRUE) END; (* Fenster bewegt? *) WM_MOVED : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Move(Msg[4], Msg[5]); (* Fenster(teil)bereich neu zeichnen? *) WM_REDRAW : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Draw(Msg[4], Msg[5], Msg[6], Msg[7]) END; DoMesag := FALSE END; (* Reaktion auf Timer-Ereignis *) PROCEDURE DoTimer; (* Variablen *) VAR anzstr : STRING[32]; NeueAnzeige : Anzeige; (* Ausgabe eines Strings in eine Dialogbox *) PROCEDURE OutString(obj : INTEGER; astr : STRING); (* Variablen *) VAR x, y : INTEGER; BEGIN (* Anzeige neu setzen *) SetPtext(MemObjTree, obj, astr); (* Offset bestimmen *) {$X+} objc_offset(MemObjTree, obj, x, y); {$X-} (* Anzeige aktualisieren *) MyWindow.Draw(x, y, MemObjTree^[obj].ob_width, MemObjTree^[obj].ob_height) END; BEGIN (* Speicheranzeige setzen *) IF Show.MemAvail THEN Show.CurrentValue := MEMAVAIL ELSE Show.CurrentValue := MAXAVAIL; (* Anzeige nur, wenn sich die Werte gendert haben *) IF (Show.CurrentValue <> Old.CurrentValue) OR (Show.MemAvail <> Old.MemAvail) THEN BEGIN STR(Show.CurrentValue, anzstr); IF Show.MemAvail THEN anzstr := '+' + anzstr; anzstr := anzstr + ' ' + 'Byte'; OutString(TMEM, anzstr); Old := Show END END; (* Reaktion auf Tastatur-Ereignis *) PROCEDURE DoKeybd(MKey : INTEGER); (* Informationsdialog ausgeben und verwalten *) {$X+} PROCEDURE DoInfo; (* Variablen *) VAR x, y, w, h : INTEGER; BEGIN (* Eingaben/Aktualisierungen sperren *) wind_update(BEG_UPDATE); (* Dialogbox zentrieren *) form_center(AboutObjTree, x, y, w, h); (* Hintergrund reservieren *) form_dial(FMD_START, x, y, w, h, x, y, w, h); (* Dialogbox ausgeben *) objc_draw(AboutObjTree, ROOT, MAX_DEPTH, x, y, w, h); (* Dialog verwalten *) form_do(AboutObjTree, ROOT); (* Status SELECTED zurcksetzen *) AboutObjTree^[BOK].ob_state := AboutObjTree^[BOK].ob_state AND NOT(SELECTED); (* Hintergrund freigeben *) form_dial(FMD_FINISH, x, y, w, h, x, y, w, h); (* Aktualisierungen wieder zulassen *) wind_update(END_UPDATE) END; {$X-} BEGIN (* Information gewnscht? *) (* Wenn ja, dann ausgeben. *) IF HI(MKey) = 98 THEN DoInfo; IF LO(MKey) = 32 THEN Show.MemAvail := NOT(Show.MemAvail) END; (* Reaktion auf Maustasten-Ereignis *) PROCEDURE DoButton(Mx, My, MButton : INTEGER); BEGIN (* Doppelklick auf TMEM? *) IF (MButton = 2) AND (objc_find(MemObjTree, ROOT, MAX_DEPTH, Mx, My) = TMEM) THEN Show.MemAvail := NOT(Show.MemAvail) END; BEGIN (* Auf diese Events wird reagiert *) IF AppFlag THEN REvent := MU_MESAG OR MU_KEYBD OR MU_BUTTON OR MU_TIMER ELSE REvent := MU_MESAG OR MU_KEYBD OR MU_BUTTON; (* Endlosschleife *) WHILE TRUE DO BEGIN (* Ereignis (Message, Maus, Tastatur oder Timer) abwarten *) Evnt := evnt_multi(REvent, 2, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, Msg, 1000, 0, Mmox, Mmoy, Mmobutton, Mmokstate, Mkreturn, Mbreturn); (* Message angekommen? *) IF (Evnt AND MU_MESAG) = MU_MESAG THEN IF DoMesag(Msg) THEN EXIT; (* Timer? *) IF (Evnt AND MU_TIMER) = MU_TIMER THEN DoTimer; (* Taste gedrckt? *) IF (Evnt AND MU_KEYBD) = MU_KEYBD THEN DoKeybd(Mkreturn); (* Mausklick? *) IF (Evnt AND MU_BUTTON) = MU_BUTTON THEN DoButton(Mmox, Mmoy, Mbreturn) END END; (* Hauptprogramm *) BEGIN (* Wenn Initialisierung nicht in Ordnung, dann Ende. *) IF NOT(InitApp) THEN EXIT; (* Programmablauf *) DoApp END. ^dsó#K,_ T9Ψ6&gʎr9pz [sBb(`VA9"o>h&!Lj=>e~F Ce #㤁HxߌHBoAedHt_~B Sb[~*E86ߊ3ug(IB9 z-͙UZ<9yfyX'3, ڎBŁ;eX6;^i#!xnz6hWѫV_9!'ZFreeMem 13. 6. 1992 Copyright (c) 1992 by Application Systems /// Heidelberg Software GmbH. Alle Rechte vorbehalten. FreeMem ist eine Speicherplatzanzeige, die im Sekundentakt aktualisiert wird und somit auch einen berblick ber die Auslastung des Speichers gibt. Bei einem Multitasking-System ist es mit dieser Anzeige mglich, den Platzbedarf einzelner Programme zu beobachten. Der Betrieb von FreeMem erfolgt als Accessory oder Programm, wobei der Programmbetrieb in erster Linie bei einem Multitasking-System interessant ist. FreeMem zeigt den grten freien Speicherblock an, wenn kein '+' vor der Byte-Zahl ist, oder den gesamten freien Speicher, wenn ein '+' zu sehen ist. Die Umschaltung erfolgt mit Doppelklick auf die Anzeige oder durch Drcken der Leertaste bei geffnetem FreeMem-Fenster. Drckt man die Taste Help, so erscheint eine kleine Programminformation. sIrhlf#U/kuJ7Jā5aȅ똕CCIVF#Bc(************************************************************************* Desktoprechner Copyright (c) 1992 by Application Systems Heidelberg. ============== Alle Rechte vorbehalten. Autor: Dietmar Rabich Unit: HANDLER.PAS Entwicklungssystem: PurePascal Der Handler bernimmt alle Eingabeauswertung (bis auf die Information). *************************************************************************) UNIT Handler; (* Die Schnittstelle zu den anderen Moduln *) INTERFACE (* Konstanten *) CONST (* Gltige Tasten *) KeyEnter = CHR(13); KeyClear = '('; KeyChangeSign = '.'; Key0 = '0'; Key1 = '1'; Key2 = '2'; Key3 = '3'; Key4 = '4'; Key5 = '5'; Key6 = '6'; Key7 = '7'; Key8 = '8'; Key9 = '9'; KeyFirstNumber = Key0; KeyLastNumber = Key9; KeyMemory = 'm'; KeyReMemory = 'r'; KeyClearMemory = 'c'; KeySwitchMemory = 's'; KeyAdd = '+'; KeyMul = '*'; KeySub = '-'; KeyDiv = '/'; (* Typen *) TYPE (* Fehlertypen *) ErrorType = (NoError, Overflow, DivisionBy0); (* Objekt Rechner *) Calculator = OBJECT (* Variablen fr Speicher, gegenwrtige Zahl und aktuelle Zahl im Speicher *) Memory, Current, Buffer : LONGINT; (* letzte Taste und letzte Operation *) LastKey, LastOp : CHAR; (* gltige Tasten *) KeyValid, KeyOper : SET OF CHAR; (* (letzter) Fehler *) Error : ErrorType; (* Konstruktor *) CONSTRUCTOR Init; (* Eingabe *) FUNCTION Input(c : CHAR) : BOOLEAN; (* Ergebnis *) FUNCTION Result : LONGINT; (* Abfrage auf Speicher *) FUNCTION MemoryEmpty : BOOLEAN; (* Abfrage des Fehlers *) FUNCTION IsError : ErrorType; END; (* Implementierung *) IMPLEMENTATION (* Funktion, die die Anzahl der Ziffern zhlt *) FUNCTION Numbers(x : LONGINT) : INTEGER; (* Variablen *) VAR LNumbers : INTEGER; BEGIN (* Ist die Zahl 0? Dann nehmen wir keine Ziffer an! *) IF x = 0 THEN Numbers := 0 ELSE BEGIN (* Anzahl der Ziffern erst einmal 0 *) LNumbers := 0; (* Schleife durchfhren, bis Zahl 0 ist *) WHILE x <> 0 DO BEGIN (* noch eine Ziffer! *) INC(LNumbers); (* nchste Ziffer *) x := x DIV 10 END; (* Anzahl der Ziffern *) Numbers := LNumbers END END; (* Konstruktor zum Initialisieren *) CONSTRUCTOR Calculator.Init; BEGIN (* Menge der gltigen Tasten *) KeyValid := [KeyFirstNumber..KeyLastNumber, KeyEnter, KeyClear, KeyChangeSign, KeyMemory, KeyReMemory, KeyClearMemory, KeySwitchMemory, KeyAdd, KeySub, KeyMul, KeyDiv]; (* Menge der gltigen Operationen *) KeyOper := [KeyAdd, KeySub, KeyMul, KeyDiv]; (* Alle Speicher lschen *) Current := 0; Memory := 0; Buffer := 0; (* letzte Operation vorerst 0 *) LastOp := CHR(0) END; (* Eingabeauswertung *) FUNCTION Calculator.Input(c : CHAR) : BOOLEAN; (* Variablen *) VAR Temp : LONGINT; TempR : REAL; BEGIN (* Erst einmal annehmen, da kein Fehler auftritt *) Error := NoError; (* Eingabe wird als wahr angenommen *) Input := TRUE; (* Falls keine gltige Taste, nichts machen und Fehler melden *) IF NOT(c IN KeyValid) THEN BEGIN Input := FALSE; EXIT END; (* Auswertung der Taste *) CASE c OF (* Zifferntaste? *) KeyFirstNumber..KeyLastNumber : (* Kein Platz mehr? *) IF Current > 1E7 THEN Error := Overflow ELSE Current := Current * 10 + ORD(c) - ORD(KeyFirstNumber); (* Vorzeichenwechsel? *) KeyChangeSign : Current := Current * -1; (* Lschen? *) KeyClear : IF LastKey = KeyClear THEN Current := 0 ELSE Current := Current DIV 10; (* aktuellen Wert speichern? *) KeyMemory : Memory := Current; (* Wert aus dem Speicher holen? *) KeyReMemory : Current := Memory; (* Speicher lschen? *) KeyClearMemory : Memory := 0; (* aktuellen Wert mit Speicher tauschen? *) KeySwitchMemory : BEGIN Temp := Memory; Memory := Current; Current := Temp END; (* Operation oder '='? *) KeyEnter, KeyAdd, KeySub, KeyDiv, KeyMul: BEGIN (* Ausfhrung von letzter Operation abhngig! *) CASE LastOp OF (* Addieren? *) KeyAdd : (* Kein Platz mehr? *) IF (Buffer + Current >= 1E8) OR (Buffer + Current <= -1E8) THEN Error := OverFlow ELSE (* Addition *) Buffer := Buffer + Current; (* Subtrahieren? *) KeySub : (* Kein Platz mehr? *) IF (Buffer + Current >= 1E8) OR (Buffer + Current <= -1E8) THEN Error := OverFlow ELSE (* Subtraktion *) Buffer := Buffer - Current; (* Multiplizieren? *) KeyMul : (* Lt die Ziffernanzahl Multiplikation zu? *) IF Numbers(Buffer) + Numbers(Current) <= 8 THEN (* Multiplikation *) Buffer := Buffer * Current ELSE Error := OverFlow; (* Dividieren? *) KeyDiv : (* Soll durch 0 geteilt werden? *) IF Current = 0 THEN Error := DivisionBy0 ELSE (* Division *) Buffer := Buffer DIV Current; (* sonst Speicher bertragen! *) ELSE Buffer := Current END; (* Gleichheitszeichen gedrckt? *) (* Sonst Puffer lschen! *) IF c = KeyEnter THEN Current := Buffer ELSE Current := 0; (* letzte Operation merken *) LastOp := c END END; (* letzte Taste merken *) LastKey := c END; (* Ergebnis zurckgeben *) FUNCTION Calculator.Result : LONGINT; BEGIN (* letzte Taste Operation? *) (* Dann Puffer zurckgeben, sonst aktuelle Zahl. *) IF LastKey IN KeyOper THEN Result := Buffer ELSE Result := Current END; (* Fehlerberprfung *) FUNCTION Calculator.IsError : ErrorType; BEGIN IsError := Error END; (* berprfung, ob Speicher leer ist *) FUNCTION Calculator.MemoryEmpty : BOOLEAN; BEGIN IF Memory = 0 THEN MemoryEmpty := TRUE ELSE MemoryEmpty := FALSE END; END.c6m&51Qo!Azw> :!&zAr} 'bm;1XSI,M7?\D ,`\'+\R-JZQo gP'v @EXE1lg֫E>Љnfi5L4A^>FOj&aƵypfRϿ/7 h#@UN`qU*N-` c}^4UgX8ad~-"PcqQirkG6)mƲp_i'iQvHY94eCXx%Oem+|_nF%MqJnϑ̣]Ham!Y2^^M&.yI9J1_ZKKi)<.6d_DZ@5Hk+; HBƵv晱6ChzI7CE`kkNi=5:jTJ״ {g sy:ʡkTs\_9QZ@w^vϐ#|*9ZLV_JIc_gA/Z"gӟu Fqpo1Zj4;]c ,И I3kci.8Ti-mV߷d8d2 e2`*e$ eeee e dB9H/?< NA\O#8Hp#>Ht#RHx#XH|#^H#dH#jHa#EHyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9HNu _0<Nh"yFb0<Na#FBgHz?<Ns`?9E?<LNAJ9Hg~p yHpav#Hpp yHtad#Htp yHxaR#Hxp yH|a@#H|p yHa.#Hp yHa#Hp yHa #HNuH瀠>NMPO @$_Nu!| 8!| R 1|װr!A!A 1A!|HSG!K&_A4<wb0w`Bp42<d0`QNur4d`QNupQNureQNu?d~V@|| dp yH"HPcR42 hPb2f@? <aR g`00$ CH$i!I!J#H%H$B#H1|2@| d($ "h$h#J%I#H$B@pXNu0#H1Ap@0Nu2 j||?dg0(Pf@|m$f`l$ CH$i!J!I#H%H$BC0k'| R OA4"O?Ho?afNAOJl a7|װ`6p&_$_Nup kױg$< 'B'B`'| B`+8<1Sbp`+8<1Ub~p`HSHR&H??<>NAXOJ@f7|װp$_&_Nua~`aP< gpNuHRHP/(/(??<?NAO _$_JkF!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R AGBapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fFNu3iFNuByHByHAp,"@ "A3@@H"`"p"@ " 1B3H"ONu/ Hz?<&NN\O$_NudNu/ f" H`@a4L g" )k!LNu )k!LNu @NuJHfAHByEBEBFByFBF FBPC!IC!I#HBHB9FNLJyHgFAFC*NAFNAGBCNAGBNNu2H4H…HB0H@0Nu2|0@A0NuNVH<.K * fD(H&LHnHnACN$POp0+Ev8+SDCmJf80Hr,Ah0NAh0.NAh0NvAh0.Nj`60Hr,Ah0N. <.B* ??024N$^XO5@0*J@l| `>2|JAgJ.cC AN" |JCgJ.c0*C AN"(LN^NuNVH *(&$H<.??0*24N$~XOJ@l| LxN^Nu0(N$Nu/ $H0*N$5|$_NuNVH8(&$HGIHnHn0*ACrN$PO?.?.?0*r4N$\OHnHn0*ACrN$PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN$\ONuNVH<*(&$H<.GIKpN%"HnHnACprN$POHTHS0*ACr N$PO`HnHn?????AC02.4NOJgXHnHn?.?.?.?.?.AC0.2.4.NOJg?.A0.2.4.NRTOHTHS0*ACr N$POJSoJTnXpN%"LXO`l&N^Nu,HHHHbb$ b,t $ D$    0 L h           , ' H  KTU V_` aefg{|} !"ABC_`OK12:34:5612/34/56UhrCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.JJf*N NN%vNNNlJgNNuI"q "QN L?/ N L$0rYO?HBa\ONu?/ N L$0rYO?HBa\ONuCJ2"<O0<H0NBL AK0Nup "<`p"<`CJ#H|p"<`HQCJ#Hd222"" """"2 Cp"<ar"_2"o2"o"2"o&2"o*2"o.2NuCO?N LCJ3_#|O|p#"<`"CJ222"2C#H|p*"<`HQCJ3@#H|p,"<a"_2"o2NuCJ3@#H|p2"<`CJ222""" Cp3"< `O"O?N L0CJ3@#O|p4"<afONuHQCJ#H|p6"<aH"_2"o2"o2"o 2NuHQHPpM"<a"_2"_2"o2"o2NuCJ3@#H|pN"<`CJ222"Cpd"<`CJ222"Cpe"<`CJ3@pf"<`CJ3@pg"<`HQHPCJ3@3Aph"<af"_2"_2"o2"o2NuCJ222"2Cpi"<`,CJ3@pk"<`HQHPCJ222" 2Cpl"<a"_2"_2"o 2"o2NuH0JP5fhN AJCOEOG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB"x N       6(N@44* 40B(h0`jVH@ h   d0 "Z4 .8N,.> v2HD r0$           ,4    8  ,X  "` *&0"T 0$> /Fu;1(nدa~ױ9}U-nzt|1m8Rq}%U$ZaM.(u[ʦ^Lz2:Vm놨bv$0^ooՅ -1 THEN appl_exit; {$X-} (* alte EXIT-Prozedur *) EXITPROC := OldProc END; (* Initialisierungsfunktion *) FUNCTION InitApp : BOOLEAN; (* Typisierte Konstanten *) CONST (* Fensterelemente *) WindowElements : INTEGER = NAME OR CLOSER OR MOVER; BEGIN (* EXIT-Prozedur anmelden *) OldProc := EXITPROC; EXITPROC := @AppExitProc; (* Anmeldung bei den AES *) appl_id := appl_init; IF appl_id < 0 THEN BEGIN appl_id := -1; InitApp := FALSE; EXIT END; (* Resourcen initialisieren und vorbereiten *) MyResource := InitResourcePool(@UhrRsc); UhrObjTree := GetResource(MyResource, UHR); AboutObjTree := GetResource(MyResource, COPYRGHT); SetPtext(UhrObjTree, TZEIT, ''); SetPtext(UhrObjTree, TDATUM, ''); (* Instanz MyWindow vorbereiten *) MyWindow.Init; MyWindow.SetTree(UhrObjTree); MyWindow.SetElements(WindowElements); (* Applikation- bzw. Accessory-spezifische Vorbereitungen *) {$X+} IF AppFlag THEN BEGIN (* Fenster ffnen *) IF NOT(MyWindow.OpenWindow(WinName)) THEN BEGIN InitApp := FALSE; EXIT END; (* Mauszeiger als Pfeil *) graf_mouse(ARROW, MFORMPtr(0)); END ELSE BEGIN (* Meneintrag *) menu_id := menu_register(appl_id, AccName); (* Kein Eintrag erfolgt? *) IF menu_id < 0 THEN BEGIN InitApp := FALSE; EXIT END END; {$X-} (* Initialisierung OK! *) InitApp := TRUE END; (* Programmverlauf *) PROCEDURE DoApp; VAR Evnt, REvent : INTEGER; (* Event *) Msg : ARRAY_8; (* Messages *) Mmox, Mmoy, (* fr Events *) Mmobutton, Mmokstate, Mkreturn, Mbreturn : INTEGER; (* Reaktion auf Message-Ereignis *) FUNCTION DoMesag(Msg : ARRAY_8) : BOOLEAN; BEGIN (* Was fr eine Nachricht? *) CASE Msg[0] OF (* Accessory geffnet? *) AC_OPEN : BEGIN {$X+} MyWindow.OpenWindow(WinName); {$X-} (* Anzeige der Uhrzeit *) REvent := REvent OR MU_TIMER END; (* Accessory geschlossen? *) AC_CLOSE : BEGIN (* keine Anzeige mehr *) REvent := REvent AND NOT(MU_TIMER); (* Fenster zu *) MyWindow.CloseWindow(FALSE) END; (* Fenster nach oben? *) WM_TOPPED: IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Top; (* Fenster geschlossen? *) WM_CLOSED : BEGIN (* keine Anzeige mehr *) REvent := REvent AND NOT(MU_TIMER); (* Wenn Programm, dann verlassen. *) (* Sonst nur Fenster schlieen. *) IF AppFlag THEN BEGIN IF MyWindow.IsHandle(Msg[3]) THEN BEGIN DoMesag := TRUE; EXIT END END ELSE MyWindow.CloseWindow(TRUE) END; (* Fenster bewegt? *) WM_MOVED : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Move(Msg[4], Msg[5]); (* Fenster(teil)bereich neu zeichnen? *) WM_REDRAW : IF MyWindow.IsHandle(Msg[3]) THEN MyWindow.Draw(Msg[4], Msg[5], Msg[6], Msg[7]) END; DoMesag := FALSE END; (* Reaktion auf Timer-Ereignis *) PROCEDURE DoTimer; (* Konstanten *) CONST TimeSep = ':'; DateSep = '/'; (* Variablen *) VAR A, B, C, Dummy : WORD; anzstr : STRING[16]; tempstr : STRING[8]; (* Ausgabe eines Strings in eine Dialogbox *) PROCEDURE OutString(obj : INTEGER; astr : STRING); (* Variablen *) VAR x, y : INTEGER; BEGIN (* Anzeige neu setzen *) SetPtext(UhrObjTree, obj, astr); (* Offset bestimmen *) {$X+} objc_offset(UhrObjTree, obj, x, y); {$X-} (* Anzeige aktualisieren *) MyWindow.Draw(x, y, UhrObjTree^[obj].ob_width, UhrObjTree^[obj].ob_height) END; BEGIN (* Zeit setzen *) GetTime(A, B, C, Dummy); STR(A:2, anzstr); anzstr := anzstr + TimeSep; STR(B:2, tempstr); anzstr := anzstr + tempstr + TimeSep; STR(C:2, tempstr); anzstr := anzstr + tempstr; OutString(TZEIT, anzstr); (* Datum setzen *) GetDate(A, B, C, Dummy); STR(C:2, anzstr); anzstr := anzstr + DateSep; STR(B:2, tempstr); anzstr := anzstr + tempstr + DateSep; STR((A MOD 100):2, tempstr); anzstr := anzstr + tempstr; OutString(TDATUM, anzstr) END; (* Reaktion auf Tastatur-Ereignis *) PROCEDURE DoKeybd(MKey : INTEGER); (* Informationsdialog ausgeben und verwalten *) {$X+} PROCEDURE DoInfo; (* Variablen *) VAR x, y, w, h : INTEGER; BEGIN (* Eingaben/Aktualisierungen sperren *) wind_update(BEG_UPDATE); (* Dialogbox zentrieren *) form_center(AboutObjTree, x, y, w, h); (* Hintergrund reservieren *) form_dial(FMD_START, x, y, w, h, x, y, w, h); (* Dialogbox ausgeben *) objc_draw(AboutObjTree, ROOT, MAX_DEPTH, x, y, w, h); (* Dialog verwalten *) form_do(AboutObjTree, ROOT); (* Status SELECTED zurcksetzen *) AboutObjTree^[BOK].ob_state := AboutObjTree^[BOK].ob_state AND NOT(SELECTED); (* Hintergrund freigeben *) form_dial(FMD_FINISH, x, y, w, h, x, y, w, h); (* Aktualisierungen wieder zulassen *) wind_update(END_UPDATE) END; {$X-} BEGIN (* Information gewnscht? *) (* Wenn ja, dann ausgeben. *) IF HI(MKey) = 98 THEN DoInfo END; BEGIN (* Auf diese Events wird reagiert *) IF AppFlag THEN REvent := MU_MESAG OR MU_KEYBD OR MU_TIMER ELSE REvent := MU_MESAG OR MU_KEYBD; (* Endlosschleife *) WHILE TRUE DO BEGIN (* Ereignis (Message, Tastatur oder Timer) abwarten *) Evnt := evnt_multi(REvent, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, Msg, 1000, 0, Mmox, Mmoy, Mmobutton, Mmokstate, Mkreturn, Mbreturn); (* Message angekommen? *) IF (Evnt AND MU_MESAG) = MU_MESAG THEN IF DoMesag(Msg) THEN EXIT; (* Timer? *) IF (Evnt AND MU_TIMER) = MU_TIMER THEN DoTimer; (* Taste gedrckt? *) IF (Evnt AND MU_KEYBD) = MU_KEYBD THEN DoKeybd(Mkreturn) END END; (* Hauptprogramm *) BEGIN (* Wenn Initialisierung nicht in Ordnung, dann Ende. *) IF NOT(InitApp) THEN EXIT; (* Programmablauf *) DoApp END. J6E>flQkb'ߎ=OUhr 13. 6. 1992 Copyright (c) 1992 by Application Systems /// Heidelberg Software GmbH. Alle Rechte vorbehalten. Uhr ist eine Datums- und Zeitanzeige, die im Sekundentakt aktualisiert wird. Der Betrieb von Uhr erfolgt als Accessory oder Programm, wobei der Programmbetrieb in erster Linie bei einem Multitasking-System interessant ist. Drckt man die Taste Help, so erscheint eine kleine Programminformation. }@ǞqLCQaNkޜNRPNf3;N^1k ՘L# x=֟J^5=nt3l%qA9!$*$FV3oY=*:e@!F@%niۈoF`RDH|mQ40|rU'T sd$;E$5Fz1_xrNAP$7^woDsI;$J/(L l ݶ9[gm} Gc:af{uHB'B)CGęny +4]ճ%H mZC{g5@Kg 7 ޴yu>"2oPޱ(^o y%Ğ6_rt,p`º*ڼړc\տt8@ 9E]r}1}Utuw23:$_#&T4pkz\PvzwNBb96\o?L>uh39xX@RECHNERTZEITTDATECOPYRGHTBOK vJV)$C 0VWr#rW-(mƦ` {g<.qA;8xnYUGCg ࠠEzC~!P#h(1S wF;!nkmC%8KatmTLlF#b7yӄ3 ?Uj)ȵ8g,37j5D5{c8|6Dgk)!ADT %geYgƐ~´oX x$Pp_9nI0sgVtL‹h ̭VbF(ճDna%`>8G9+[-e[^K<+kTKomφ:0Q0i^u;~Z>Fr~[څŗ8kr.YrnYn-3ֶ4;y;zmL?W̿wL^.~1? _eS9;h_K~of[NncjTl-Ѷa(iuٱK'`eKZQsHȐ6˯/s*F9 %3&MJOt[Eou69L4U 8ZHҪsxȥ&oL9K~ g ~_)XsvТ򍶙UcJ(t`g`Z'Zd/6DFRECHNERTZEITTDATECOPYRGHTBOKY9 " "2 AG@V Um^ !VQ OŘG{`B7!.;vEŻ{LY"Lj@BgXP̀*T-)  PA٣ ;VtM2=ù׷vnb*y/PF+w~I9boXOHJxڰ58JUikʖ' IJ%=Їs%\q ŒeT߀vج #N YA*RW=ӐRjL/o71J{$ے )0]׽sw"aGl+}#DZA[B7ԋGˌ-'>Qu?(X;3=8I@^YsOk@Bi;ϸ~fZ;欭Ҷ\fBB7r;Yl_WY*.wuvjuhTw-%^ ~~v9NLWY, =;ʟS>1Ԭ[0zd3of/zsC)9߮aa.OME ) (;(m% `Yc:+afV_DJឮ ?`#vk Y/i]à\ݾQGFBp՜/ V[+^cT _J:rfi=v0zH8,E˅K;%q6[Q>;B&"(u,,% kåa׭ _Xg압S[[Mzz.Bƻ>j֖C zPb%:kchV^d9g/>w|Lg>{BϾh4i/PV[i{FJ|Mjc;fl-eTRRIM-UHRTZEITTDATUMCOPYRGHTBOK|߿-c͇~ِPZ|b_O)~zPHx2a 欈+ɡfS5 sdbK04M־"څ3h ҳ'S4%k>%5noQ*edj<r+'4$=K1ץN;0Wek L(NlΪ\'L,.o-rõ dGF 7wk~qtlɡ(* Resource Datei Indizes fr UHRRSC *) CONST UHR = 0; (* Formular/Dialog *) TZEIT = 1; (* TEXT in Baum UHR *) TDATUM = 2; (* TEXT in Baum UHR *) COPYRGHT = 1; (* Formular/Dialog *) BOK = 14; (* BUTTON in Baum COPYRGHT *) @cVD.<>mܠ "̀A >I4e!2;䒃a-Ii;̾ZN?V@m3F#z޽8bX{OiJ'iCiA/lCPrag Oom]i FK^NUkTt W.HDQ%3?ސM&5(++iyp-ZLa ~"^{m -O{-+,lr,fbuj\GdL]c){BW5,lӻC89cnFui<͒u4;1I񬵃e@&ͳ|9MEe5YK+5Pv.5Ib9(Ǖsb73Z괦pO RII?v(1XƺS :tUrݐL=w9W_%}t%!qbeZժ"~0+ɐ%!%p09m]gr 9jmWe$SH J&]l÷Y[Ct5QzOq^B |Q \S}{xz}g⡝gf?}R]j ]zY- HﱶM6ɽ5D8hm2쮇.;ۖ'ĦZ7D=>,*tϳ,7?5oZn`ߋ!axlqF֌2b| i i+ti]|mJm jL]sa2[qtSTn@\"zW'5F[}n`ahdf-)ʩ9*lLq1CVR ˰ 4E;Y;fgvw&+{sk.5OLVIלwgZAP)Cֺ@#]Z!uf[{tBbzq&_; Uh%ʲ3ҵe"vKwL&W6D HDl"MF <\7}v|0wF;Ȉ9qo8!pQXym97#+ $ͤTlXfPX )8s8~0]fS`L)WAf4銋\ #HMR$ÌnFcUr٣P#yLfHV3 A&3OOB䢂l=jlx~-&=i%(}bLpD-;'2pý6OTx? . |? `7 9<*Qnfʲ)ȭӷP;,s{n #ȕZg kƠhBƾjQuFe1M e18FqDRECHNERTZEITTDATECOPYRGHTBOKԻi2]ޞ!% lM`ݶmt?g3 s?=>ǖyO|DN||MbmT4.ĉlֻ$΄[JCg/aB]ѹ)&*#zAA!62@D+[h n] (hm0oU!3A4]n rQujӗ[w|s{mE3X *k]:Ԛ1Zz,bN@Z]kT"[_nLuVq% ĉkH.)Wma#ۖ284bLah*]2Xe}ٸdHYT`)\b"b[V3io{XQo1ѭQ4!EHl#Wi?9SwS!Ɨ4yXё T %m(!\^y]WF ϫ~Gz7rG9t 2 Ȯ^`<;+}W/9_MfOl]'j-`9l,9Ct);4,fdAgKc''uxjz{opUՓiВᒢ\A~jKO\1yu˼wbH)Rr"+VMC HY'gPrA=<>fϽ8zKXTMC8("yU^ƔgOc 3;Z}c68t4tnB+Z gMY+*;`0NJ#0NNX@---------------- Pure Pascal for Atari STe/TT Version 1.0 (c) 1992 Pure Software GmbH ----------------3pT`BpVN ypV fJp^gaFaH ypZN Runtime error at offset $0123456789ABCDEFHP?< NA\ONuOAa09pTr Oa j OpB0a&yrJ g.Aa&9p^8<|;??<NAXOQ?<NAO Nur&H fr&os pR + Ым*@Ы,UC#pn"k" <*AYM#r.M// ?<?<JNAO #rpr+g|<fB k, AfE"H gJ"gJfJf`VARGV=XOA$H`JgBR@JfHR$H`A"HB0< c<"frJg "f`B(R@HQ"HJf*3rJ9s gB?< NA\O x"( e\$<dzet dn ehdbe\dVePdJeDd>e8 d2 e,`0e$ eeee e dB9s /?< NA\O#hr#nr#r#r#r#r#ra#pZHyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9rNu _0<Nh"ypnb0<Na#p^BgHz?<Ns`?9pT?<LNAJ9s g~p yrav#rp yrad#rp yraR#rp yra@#rp yra.#rp yra#rp yra #rNuH瀠>NMPO @$_NuHR!| 1|װr!A!A 1A!|E!JA4pxd2EN`QB$_Nup42<d0`QNupQNu?d~V@|| dp ys"HPcR42 hPb2f@? <aR g`00$ Cr$i!I!J#H%H$B#s1|2@| d($ "h$h#J%I#s$B@pXNu0#s1Ap@0Nu2 j||?dg0(Pf@|m$f`l$ Cr$i!J!I#H%H$BC0k?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~pJ@k hײeH&H(I6xc`p aQ`aQJypff (g "@N3pf KLNuC` rlCAS QSr QNuJypffn"( b2(f* (gHP"@N _3pffFJ f`2"("hg1` 1R!A<g̰< g(Nu$jD BJjD$HBJBf.$HBJBfH@B@H@$jDNuB@H@HB2@0H@0 H@`?BCdQCJkSCҁ[DCHAt4B@H@HBBHBHA60dSCp06`$jD BJjD$HBJBf$HBJBf $jDNuHBЂ$`HBЂ`p`QBNuJypff0"h"(R!A (Se (gHP"@N3pf _NuRHHPJ@l JAg-D@C&Ye2)t AUA 2f"_ Nu'd 09876543210a3pfNuJlD@| |l@0; `p`pNuHRHS&Hp'@'@'@ 0+|ױg$< 'B|ײf2<<`'| P'| dp`7|ײ2<=J+4gl$+4NULgVAUXgPRNgCONgDļLPTgtCOMgV'| ( ?Hk4?NAPOJl a 7|װ`6p&_$_Nup kױg$< 'B'B`'| B`+7<1SbJ+8fp`+7<1UbJ+8fp`HSHR&H??<>NAXOJ@f7|װp$_&_Nua`a< gpNuHRHP/(/(??<?NAO _$_JkH!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R AqapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fpfNu3ipfNuBBJAb 0 VDNuBNuBysByrAp,"@ "A3@@r"`"p"@ "1B3r"ONu/ Hz?<&NN\O$_NuJ9ro@'h0T Nu2<@Jg@jD|bH@|bQAbYAJkSAЀj0 BNuBA`|b @0; gaNuJ9roD/(/(Bg?H/)/)Bg?H8DNuDNuDNuDNuHHz `lp`N````` ` ``2NqNqNqJ@jR@fJjFFF@JCjRCfJjFFFCCg mB@DLxNup`p`6C`6*)<<HFFg6()kfJfU`SCڅلj0"$HFFgJjNuf4Jf0]Nu()fJfY`JfJf  Nu\HNuJkS@ԂӁjNu0<rtv`H@Frtv`<<6(FgF Cpn @b:H@@9s g 9s g 69s[Ck S@rt`rtv` @n0H@@rtv9s gv9s gl89s\Dj`t`PvxR@fЀP9s fg,` 9s g 9s gJ@k`J@j JgRdR !1.Nuv]H//?HW//0aPO0 ]H.NudNu/ f" H`@abL g" )k!LNu )k!LNu @NuJs fArBypTBpVBp^BypfBphplBPC!IC!I#sBsB9pmNbJyrgpmAprC*N6AprNAqCNAqNNuNVAspN* yuN!J9pRf AN,` ys gN,~#u,pVN^Nu #pVu,A#pVN,r3s Jys l3s p` |N"#u yupN"6#u$ yupN"6#u( yu$pCN+Au0C"^N"As"yu$N)VAs09N)\J9pRg$AsCDN)bJfp`0pN.`"09s A*N-:3sJyslp`pNu0 Sweetie Sweetie...cmrs(? / *-+ .0123456 7 8 9NVH8(I&H? yu$rt@AN-TO6 Cg<$|xRf*Sp*8HnHnACprtN,POXQLN^NuNV-X-X-X-X0.||b@0;NRx,@AsCN)b`AspN*`As0.N)LJgAsN(`J9pRgAs0.N)LJgrp`p`lAspN*`\As0.N)LJgHAs0.2.N't`2As0.N)LJg?.As0.2.4.N((TOpN^Nu Sweetie NVH. <.B* ??024N.XO5@0*J@l| `>2|JAgJ.cC AN, |JCgJ.c0*C AN,*LN^NuNVH *(&$H<.??0*24N.XOJ@l| LxN^Nu0(N.Nu/ $H0*N/5|$_NuNVH8(&$HGIHnHn0*ACrN/(PO?.?.?0*r4N/\\OHnHn0*ACrN/(PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN/\\ONuNVH<*(&$H<.GIKpN/HnHnACprN/(POHTHS0*ACr N/(PO`HnHn?????AC02.4N+nOJgXHnHn?.?.?.?.?.AC0.2.4.N+nOJg?.A0.2.4.N+4TOHTHS0*ACr N/(POJSoJTnXpN/LCu3@pg"<`(HQHPCu3@3Aph"<a "_2"_2"o2"o2NuCu222"2Cpi"<`Cu3@pk"<`HQHPCu222" 2Cpl"<a"_2"_2"o 2"o2NuH0JzfhNAuCzvEzbG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB" N       :^6(N@44* 40B(20`jZ8@  4 &          .p      2  x      Hj( $h(6*b( h4 .8N,.> v2HD  &4` (&&0"T 0$>d#*^Tdʔ͑^jPeKӡq,͞losC@@t`|[8;ڐ_jz(ܷu>my\&f""bȲJߒ1Ǝ갯af#Z秐 u@Z?XgÙ5ZOoB1[R!,-r v X]ńjGi!$$JR!vbǻHryR9s5peՀYU_ũ˄4H gQxOn4nKtG(',^b?V G~M}94dl]B"wF '0x1ɣh)̾RJ?)="1\CoUUrj-+Λ\_g+?mݫD"bn9Ҽ~Ek`#&*R##&NX ---------------- Pure Pascal for Atari STe/TT Version 1.0 (c) 1992 Pure Software GmbH ----------------3C,`BC.N yC. fJC6gaFa yC2N Runtime error at offset $0123456789ABCDEFHP?< NA\ONuOAa09C,r Oa OpB0a&yEJ g.Aa&9C68<|;??<NAXOQ?<NAO Nur&H fr&oEC* + Ым*@Ы,UC#CB"k" <*AYM#E.M// ?<?<JNAO #Epr+g|<fB k, AfE"H gJ"gJfJf`VARGV=XOA$H`JgBR@JfHR$H`A"HB0< c<"frJg "f`B(R@HQ"HJf*3EJ9EgB?< NA\O x"( e,dP dJdDd>d8d2 e2`*e$ eeee e dB9E/?< NA\O#8E#>E#RE#XE#^E#dE#jEa#C2HyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9ENu _0<Nh"yCBb0<Na#C6BgHz?<Ns`?9C,?<LNAJ9Eg~p yEav#Ep yEad#Ep yEaR#Ep yEa@#Ep yEa.#Ep yEa#Ep yEa #ENuH瀠>NMPO @$_Nu!|!| 1|װr!A!A 1A!|HSG!K&_A4<wb0w`Bp42<d0`QNur4d`QNupQNureQNu/ Hx?<HNA\$_UeNu yE"Hp0"iQd0fU?m <?NuH0vHx?<HNA\eր/?<HNA\Jg&` g&S/?<INA\`p yE"H"i0րf L Nu0(|װ|װfHS&H kװg + g "@N3C:RkB+ +g "@ KN3C:&_Nu0(|װ|װfHS&H kװg + g "@N3C:TkB+ +g "@ KN3C:&_Nur?RHHPJl-DC*e")t UЁ E"f  _0`;B@'d 09876543210pJ@k hײe H&H(I6xc`p aQ`aQJyC:f (g "@N3C: KLNuC` rlCAS QSr QNuJyC:fv"( b2(f* (gHP"@N _3C:fNJ f`:"("hgf1` 1R!A<gİ< g(Nup`QBNuJyC:f0"h"(R!A (Se (gHP"@N3C: _NuRHHPJ@l JAg-D@C&Ye2)t AUA 2f"_ Nu'd 09876543210a3C:NuJlD@| |l@0; `p`pNuHRHS&Hp'@'@'@ 0+|ױg$< >'B|ײf2<<`'| '| p`7|ײ2<=J+4gx$+4NULgbAUXgPRNgLPTgCOMgnCONg>'| OA4"O?Ho?afNAOJl a7|װ`6p&_$_Nup kױg$< 'B'B`'| lB`+8<1Sbp`+8<1Ub~p`HSHR&H??<>NAXOJ@f7|װp$_&_Nua~`aP< gpNuHRHP/(/(??<?NAO _$_JkF!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R ADtapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fC:Nu3iC:NuByEByEAp,"@ "A3@@E"`"p"@ " (1B3E"ONu/ Hz?<&NN\O$_NuJEfAEByC,BC.BC6ByC:BC<C@BPC!IC!I#EBEB9CANJyEgCAACFC*NACFNADtCNADtN$Nu2H4H…HB0H@0Nu2|0@A0NuNVH<.K * fD(H&LHnHnACN!TPOp0+Ev8+SDCmJf80Hr,Ah0NAh0.NAh0NvAh0.Nj`60Hr,Ah0N. <.B* ??024N!XO5@0*J@l| `>2|JAgJ.cC AN|JCgJ.c0*C AN:LN^NuNVH *(&$H<.??0*24N!XOJ@l| LxN^Nu0(N!Nu/ $H0*N!5|$_NuNVH8(&$HGIHnHn0*ACrN"PO?.?.?0*r4N"4\OHnHn0*ACrN"PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN"4\ONuNVH<*(&$H<.GIKpN"XHnHnACprN"POHTHS0*ACr N"PO`HnHn?????AC02.4NOJgXHnHn?.?.?.?.?.AC0.2.4.NOJg?.A0.2.4.NnTOHTHS0*ACr N"POJSoJTnXpN"XL\O&N^Nu@m0Nu@n0NuNVH<*I(H.(&&n$n<. :. 02N802N:0G2nN40R0n2nN60SJRoJSnB@`pL\O yGpN yGhZ??????p24N O pN"XL<N^NuNV/&0H@bf/N6XO|C fJ9H gB@`pH &N^NuH*(&UEf.? yGpr4N fTOS@fJ9H gB@`pH L8NuNV/J9C*g=|3`=|HnHnHnHnHnBg?<BgBgBgBgBgBgBgBgBgBg?<AC0.rtNO.60|@f/ANXOJfF0| @ f/NFXO0|S@f /0.NXO|UCf0.2.4.N`R&N^Nu,..$ .,\ $ D$      4 P  l         '   '()123GHIhijyz{ +,OK1234567890 ByteFreeMemCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.JHf$N @N"NN(NJgNNuI"q "QN?/ N$0rYO?HBa\ONu?/ N$0rYO?HBa\ONuCH2"<M0<H0NBL AI80Nup "<`p"<`CH#H|p"<`HQCH0#Hd222"" """"2 Cp"<ar"_2"o2"o"2"o&2"o*2"o.2NuCM?NCH3_#|M|p#"<`"CH0222"2C#H|p*"<`CH02222C#H|p+"<`HQCH3@#H|p,"<a"_2"o2NuCH3@#H|p2"<`CH0222""" Cp3"< `lO"O?N0CH3@#O|p4"<aBONuHQCH#H|p6"<a$"_2"o2"o2"o 2NuHQHPpM"<a"_2"_2"o2"o2NuCH3@#H|pN"<`CH0222"Cpd"<`CH0222"Cpe"<`CH3@pf"<`vCH3@pg"<``HQHPCH3@3Aph"<aB"_2"_2"o2"o2NuCH0222"2Cpi"<`CH3@pk"<`HQHPCH0222" 2Cpl"<a"_2"_2"o 2"o2NuH0JMofhN @AHCMELG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB"x N       rB0B(h0`jVH@    d( h4 .8N,.> v2HD           0  6  2 X  "` (&&0"T 0$>.㼁)wVwU[PX+Qu5.k:6(gtPf%C֣Cr֣f׬U֣7G+usvÿvt`J)] Zm@&&U,P5ṋqdk˹\hy*Z^]@0 skf}2'sZ8U0_ǀf;Z\uhXZփ3N̓ki(g7U ?Ş3?"`/vp3T/$A"cg AY$ T&1(ϒD#D2<)|6lZJDR/C)#$q(=+HvIVu6= мR ld,V6% A}5cp8+?`_/8/{081HUTG''h~[\] Q5GѿCzIQQtk;vtԈ{]oUux)u] m ˛Xqd v(fw ZBk}fw,4x'%ya ٌo]n/M[o-fnatr4Rzt,N;XR6jU-|:\TZ{~f76']@m}[*Q( XvO#,rR˥>ہYgŝ 0K#̌9&^uDsRA)1bP1vOh@hc1iК\ jVvMbѡv`%*P#!%NX ---------------- Pure Pascal for Atari STe/TT Version 1.0 (c) 1992 Pure Software GmbH ----------------3E`BEN yE fJFgaFa yEN Runtime error at offset $0123456789ABCDEFHP?< NA\ONuOAa09Er Oa OpB0a&yHJ g.Aa&9F8<|;??<NAXOQ?<NAO Nur&H fr&oHE + Ым*@Ы,UC#F"k" <*AYM#H.M// ?<?<JNAO #Hpr+g|<fB k, AfE"H gJ"gJfJf`VARGV=XOA$H`JgBR@JfHR$H`A"HB0< c<"frJg "f`B(R@HQ"HJf*3HJ9HgB?< NA\O x"( e,dP dJdDd>d8d2 e2`*e$ eeee e dB9H/?< NA\O#8Hp#>Ht#RHx#XH|#^H#dH#jHa#EHyN0<`0<r;kB/o `:0<`40<`.0<`(0<`"HP o P@e P@b _/9HNu _0<Nh"yFb0<Na#FBgHz?<Ns`?9E?<LNAJ9Hg~p yHpav#Hpp yHtad#Htp yHxaR#Hxp yH|a@#H|p yHa.#Hp yHa#Hp yHa #HNuH瀠>NMPO @$_Nu!| 8!| R 1|װr!A!A 1A!|HSG!K&_A4<wb0w`Bp42<d0`QNur4d`QNupQNureQNu?d~V@|| dp yH"HPcR42 hPb2f@? <aR g`00$ CH$i!I!J#H%H$B#H1|2@| d($ "h$h#J%I#H$B@pXNu0#H1Ap@0Nu2 j||?dg0(Pf@|m$f`l$ CH$i!J!I#H%H$BC0k'| R OA4"O?Ho?afNAOJl a7|װ`6p&_$_Nup kױg$< 'B'B`'| B`+8<1Sbp`+8<1Ub~p`HSHR&H??<>NAXOJ@f7|װp$_&_Nua~`aP< gpNuHRHP/(/(??<?NAO _$_JkF!@ BpNuHRHP/(/(??<@NAO _$_JkBB pNuHPa _J@f$"( g"h R AGBapNuHRHP"h (B1HQ?< NA\O _$_JkBB pNu3fFNu3iFNuByHByHAp,"@ "A3@@H"`"p"@ " 1B3H"ONu/ Hz?<&NN\O$_NudNu/ f" H`@a4L g" )k!LNu )k!LNu @NuJHfAHByEBEBFByFBF FBPC!IC!I#HBHB9FNLJyHgFAFC*NAFNAGBCNAGBNNu2H4H…HB0H@0Nu2|0@A0NuNVH<.K * fD(H&LHnHnACN$POp0+Ev8+SDCmJf80Hr,Ah0NAh0.NAh0NvAh0.Nj`60Hr,Ah0N. <.B* ??024N$^XO5@0*J@l| `>2|JAgJ.cC AN" |JCgJ.c0*C AN"(LN^NuNVH *(&$H<.??0*24N$~XOJ@l| LxN^Nu0(N$Nu/ $H0*N$5|$_NuNVH8(&$HGIHnHn0*ACrN$PO?.?.?0*r4N$\OHnHn0*ACrN$PO0R jh4 j1S0j jh5@ j1TLN^NuBgBgBg0(r tN$\ONuNVH<*(&$H<.GIKpN%"HnHnACprN$POHTHS0*ACr N$PO`HnHn?????AC02.4NOJgXHnHn?.?.?.?.?.AC0.2.4.NOJg?.A0.2.4.NRTOHTHS0*ACr N$POJSoJTnXpN%"LXO`l&N^Nu,HHHHbb$ b,t $ D$    0 L h           , ' H  KTU V_` aefg{|} !"ABC_`OK12:34:5612/34/56UhrCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.JJf*N NN%vNNNlJgNNuI"q "QN L?/ N L$0rYO?HBa\ONu?/ N L$0rYO?HBa\ONuCJ2"<O0<H0NBL AK0Nup "<`p"<`CJ#H|p"<`HQCJ#Hd222"" """"2 Cp"<ar"_2"o2"o"2"o&2"o*2"o.2NuCO?N LCJ3_#|O|p#"<`"CJ222"2C#H|p*"<`HQCJ3@#H|p,"<a"_2"o2NuCJ3@#H|p2"<`CJ222""" Cp3"< `O"O?N L0CJ3@#O|p4"<afONuHQCJ#H|p6"<aH"_2"o2"o2"o 2NuHQHPpM"<a"_2"_2"o2"o2NuCJ3@#H|pN"<`CJ222"Cpd"<`CJ222"Cpe"<`CJ3@pf"<`CJ3@pg"<`HQHPCJ3@3Aph"<af"_2"_2"o2"o2NuCJ222"2Cpi"<`,CJ3@pk"<`HQHPCJ222" 2Cpl"<a"_2"_2"o 2"o2NuH0JP5fhN AJCOEOG"G#KG#KG #K G|#KG#KC$C%IC8%IC %I AZ%HL Nuz LB"x N       6(N@44* 40B(h0`jVH@ h   d0 "Z4 .8N,.> v2HD r0$           ,4    8  ,X  "` *&0"T 0$>aq6:#jd0?Y."jMqڐT!4Sf[ћs3Lm1~iq6KΡ[29=%HmSddtY'=4T!aYOҋe?ϿN*)jG!Π_PJ/q`%ag@9ʁiSFE0UA.t(************************************************************************* FreeMem/Sweetie/Uhr =================== Copyright (c) 1992 by Application Systems Heidelberg. Alle Rechte vorbehalten. Autor: Dietmar Rabich Unit: WINDOWS.PAS Entwicklungssystem: PurePascal Diese Unit bernimmt das Windowhandling. *************************************************************************) UNIT OWindows; (* Die Schnittstelle zu den anderen Moduln *) INTERFACE (* Unit GEM wird bentigt *) USES Gem; (* Typen *) TYPE (* Rechteck *) Rectangle = RECORD x, y, w, h : INTEGER END; (* Object Rechnerfenster *) ObjWindow = OBJECT (* Objektgre *) ObjSize : Rectangle; (* Handle des Fensters *) w_handle : INTEGER; (* Zentrierflag *) IsCentered, (* Fehlerflag *) IsError : BOOLEAN; (* String fr Titel und Infozeile *) WinTitleStr, WinInfoStr : STRING; (* Fensterstatus *) WindowState : (No, Created, Opened); (* Zeiger auf Objektbaum *) ObjTree : AESTreePtr; (* Fensterelemente *) Elements : INTEGER; (* Initialisierung *) CONSTRUCTOR Init; (* Fenster anlegen *) PROCEDURE Create(kind, wx, wy, ww, wh : INTEGER; titlestr, infostr : STRING); (* Fenster ffnen *) PROCEDURE Open(wx, wy, ww, wh : INTEGER); (* Fenster schlieen *) PROCEDURE Close; (* Fenster lschen *) PROCEDURE Destroy; (* Fenster bewegen *) PROCEDURE Move(newx, newy : INTEGER); (* Fenster nach oben bringen *) PROCEDURE Top; (* Fensterinhalt ausgeben *) PROCEDURE Draw(cx, cy, cw, ch : INTEGER); (* Ausschnitt ausgeben *) PROCEDURE DrawObj(cx, cy, cw, ch : INTEGER); (* Objektbaum setzen *) PROCEDURE SetTree(Tree : AESTreePtr); (* Elemente setzen *) PROCEDURE SetElements(Elem : INTEGER); (* Rechnerfenster schlieen *) PROCEDURE CloseWindow(ReallyClose : BOOLEAN); (* Rechnerfenster ffnen *) FUNCTION OpenWindow(Title : STRING) : BOOLEAN; (* Elemente abfragen *) FUNCTION GetElements : INTEGER; (* Fehler abfragen *) FUNCTION Error : BOOLEAN; (* Handle prfen *) FUNCTION IsHandle(handle : INTEGER) : BOOLEAN; END; (* Schnittrechteck bestimmen *) FUNCTION RectIntersect(xa, ya, wa, ha, xb, yb, wb, hb : INTEGER; VAR xi, yi, wi, hi : INTEGER) : BOOLEAN; (* Kurze (Negativ-)Meldung ausgeben *) FUNCTION BadAlert(s : STRING) : STRING; (* Implementation *) IMPLEMENTATION (* Konstanten *) CONST (* fr Alertbox *) BadAlertIcon = '[3]['; BadAlertButton = '][ Abbruch ]'; NoWindow = 'Das Fenster lt sich|nicht ffnen!|' + 'Versuchen Sie es erneut,|wenn Sie ' + 'ein anderes|geschlossen haben.'; (* Kennzeichen fr kein Fenster *) NoWindowId = -1; (* Negativalert-Text *) FUNCTION BadAlert(s : STRING) : STRING; BEGIN BadAlert := BadAlertIcon + s + BadAlertButton END; (* Initialisierung *) CONSTRUCTOR ObjWindow.Init; BEGIN (* Zentrierflag vorbesetzen *) IsCentered := FALSE END; (* Fenster anlegen *) PROCEDURE ObjWindow.Create(kind, wx, wy, ww, wh : INTEGER; titlestr, infostr : STRING); BEGIN (* Fehlerflag vorbesetzen *) IsError := FALSE; (* Fenster anlegen *) w_handle := wind_create(kind, wx, wy, ww, wh); (* Handle ungltig? Dann Fehlers setzen. *) IF w_handle < 0 THEN IsError := TRUE ELSE BEGIN (* Fenstertitel setzen? *) IF ((kind AND NAME) <> 0) AND (LENGTH(titlestr) > 0) THEN WindSetTitle(w_handle, titlestr, WinTitleStr); (* Informationszeile setzen? *) IF ((kind AND INFO) <> 0) AND (LENGTH(infostr) > 0) THEN WindSetInfo(w_handle, infostr, WinInfoStr) END END; (* Fenster ffnen *) PROCEDURE ObjWindow.Open(wx, wy, ww, wh : INTEGER); BEGIN IF wind_open(w_handle, wx, wy, ww, wh) < 0 THEN IsError := TRUE END; (* Fenster schlieen *) {$X+} PROCEDURE ObjWindow.Close; BEGIN wind_close(w_handle) END; {$X-} (* Fenster lschen *) {$X+} PROCEDURE ObjWindow.Destroy; BEGIN wind_delete(w_handle); w_handle := NoWindowId END; {$X-} (* Fenster bewegen *) {$X+} PROCEDURE ObjWindow.Move(newx, newy : INTEGER); (* Variablen *) VAR x, y, w, h : INTEGER; BEGIN (* aktuelle Koordinaten ermitteln *) wind_get(w_handle, WF_CURRXYWH, x, y, w, h); (* neue Koordinaten setzen *) wind_set(w_handle, WF_CURRXYWH, newx, newy, w, h); (* neue Koordinaten der Arbeitsbereichs ermitteln *) wind_get(w_handle, WF_WORKXYWH, x, y, w, h); (* Objektbaum anpassen *) ObjSize.x := x + ObjSize.x - ObjTree^[0].ob_x; ObjTree^[0].ob_x := x; ObjSize.y := y + ObjSize.y - ObjTree^[0].ob_y; ObjTree^[0].ob_y := y END; {$X-} (* Fenster nach oben bringen *) {$X+} PROCEDURE ObjWindow.Top; BEGIN wind_set(w_handle, WF_TOP, 0, 0, 0, 0) END; {$X-} (* Fensterinhalt ausgeben *) {$X+} PROCEDURE ObjWindow.Draw(cx, cy, cw, ch : INTEGER); VAR fx, fy, fw, fh, rx, ry, rw, rh, ix, iy, iw, ih : INTEGER; BEGIN (* Ausgaben andere sperren *) wind_update(BEG_UPDATE); (* Desktop-Arbeitsbereich ermitteln *) wind_get(0, WF_WORKXYWH, fx, fy, fw, fh); (* erstes Rechteck der Liste holen *) wind_get(w_handle, WF_FIRSTXYWH, rx, ry, rw, rh); (* zeichnen, so lange Breite und Hhe ungleich 0 *) WHILE (rw > 0) AND (rh > 0) DO BEGIN (* Clipping erstes Rechteck mit Wunschrechteck *) IF RectIntersect(rx, ry, rw, rh, cx, cy, cw, ch, ix, iy, iw, ih) THEN (* Clipping des vorigen Ergebnis mit Desktop-Arbeitsbereich *) IF RectIntersect(fx, fy, fw, fh, ix, iy, iw, ih, ix, iy, iw, ih) THEN (* Teil des Arbeitsbereichs neu zeichnen *) DrawObj(ix, iy, iw, ih); (* nchstes Rechteck der Liste *) wind_get(w_handle, WF_NEXTXYWH, rx, ry, rw, rh); END; (* Ausgabe andere wieder ermglichen *) wind_update(END_UPDATE) END; {$X-} (* Fehler abfragen *) FUNCTION ObjWindow.Error : BOOLEAN; BEGIN Error := IsError; IsError := FALSE END; (* Handle prfen *) FUNCTION ObjWindow.IsHandle(handle : INTEGER) : BOOLEAN; BEGIN IsHandle := (handle = w_handle) END; (* Objektbaum setzen *) PROCEDURE ObjWindow.SetTree(Tree : AESTreePtr); BEGIN ObjTree := Tree END; (* Fensterelemente setzen *) PROCEDURE ObjWindow.SetElements(Elem : INTEGER); BEGIN Elements := Elem END; (* Fensterelemente ermitteln *) FUNCTION ObjWindow.GetElements : INTEGER; BEGIN GetElements := Elements END; (* Rechnerfenster ffnen *) FUNCTION ObjWindow.OpenWindow(Title : STRING) : BOOLEAN; (* Variablen *) VAR WindowSize : Rectangle; BEGIN (* Geffnet? Dann nur nach oben bringen. Sonst ffnen. *) IF WindowState = Opened THEN BEGIN Top; OpenWindow := TRUE END ELSE BEGIN {$X+} (* Objektbaum zentrieren *) IF NOT(IsCentered) THEN BEGIN form_center(ObjTree, ObjSize.x, ObjSize.y, ObjSize.w, ObjSize.h); IsCentered := TRUE END; (* Fenstergre berechnen *) wind_calc(0, Elements, ObjSize.x, ObjSize.y, ObjSize.w, ObjSize.h, WindowSize.x, WindowSize.y, WindowSize.w, WindowSize.h); (* Fenster ffnen *) Create(Elements, WindowSize.x, WindowSize.y, WindowSize.w, WindowSize.h, Title, ''); (* Fehler? Dann Schlu. *) IF Error THEN BEGIN form_alert(1, BadAlert(NoWindow)); OpenWindow := FALSE; EXIT END ELSE BEGIN (* Fenster angelegt! *) WindowState := Created; (* Fenster ffnen *) Open(WindowSize.x, WindowSize.y, WindowSize.w, WindowSize.h); (* Fehler? Dann Schlu. *) IF Error THEN BEGIN form_alert(1, BadAlert(NoWindow)); OpenWindow := FALSE; EXIT END ELSE (* Fenster geffnet! *) WindowState := Opened END; {$X-} OpenWindow := TRUE END END; (* Rechnerfenster schlieen *) PROCEDURE ObjWindow.CloseWindow(ReallyClose : BOOLEAN); BEGIN (* Ganz und gar schlieen? *) IF ReallyClose THEN BEGIN (* Geffnet? Dann schlieen und lschen! *) IF WindowState = Opened THEN BEGIN Close; Destroy END; (* Nicht geffnet, aber angelegt? Dann lschen! *) IF WindowState = Created THEN Destroy END ELSE (* Nur lschen, da Fenster mit Sicherheit geschlossen. *) IF (WindowState = Created) OR (WindowState = Opened) THEN Destroy; (* Kein Fenster mehr! *) WindowState := No END; (* Teilbereich neu zeichnen *) {$X+} PROCEDURE ObjWindow.DrawObj(cx, cy, cw, ch : INTEGER); BEGIN (* Ausgabe *) objc_draw(ObjTree, ROOT, MAX_DEPTH, cx, cy, cw, ch) END; {$X-} (* Schnittrechteck berechnen *) FUNCTION RectIntersect(xa, ya, wa, ha, xb, yb, wb, hb : INTEGER; VAR xi, yi, wi, hi : INTEGER) : BOOLEAN; (* Maximum *) FUNCTION Max(x, y : INTEGER) : INTEGER; BEGIN IF x > y THEN Max := x ELSE Max := y END; (* Minimum *) FUNCTION Min(x, y : INTEGER) : INTEGER; BEGIN IF x < y THEN Min := x ELSE Min := y END; BEGIN (* maximale X-Koordinate *) xi := Max(xa, xb); (* maximale Y-Koordinate *) yi := Max(ya, yb); (* minimale Breite *) wi := Min(xa + wa, xb + wb); DEC(wi, xi); (* minimale Hhe *) hi := Min(ya + ha, yb + hb); DEC(hi, yi); (* Rechteck ermittelt? *) RectIntersect := (wi > 0) AND (hi > 0) END; END. BrowserClose; end; var browserApplication : TBrowserApplication; { ------------------------------------------------------------ } { this is the external start address of the resource file. } { resource file was converted into an object file using the } { utility BINOBJ, so it can be linked to the program. } { BINOBJ was invoked with the commandline } { browser.rsc browser.o browserResources } { ------------------------------------------------------------ } N,$(, 00$0@ 0\0C 0? 0/  0* 07 0809 0-040506 0+010203 0=00  0 $ D$x              < X  t  '     !"234HIJ`abxyzOK0123456789CMMRMSMSweetieCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.CalcRscN.,..$ .,\ $ D$      4 P  l         '   '()123GHIhijyz{ +,OK1234567890 ByteFreeMemCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal..FmRscNb,HHHHbb$ b,t $ D$    0 L h           , ' H  KTU V_` aefg{|} !"ABC_`OK12:34:5612/34/56UhrCopyright 1992 byApplication Systems HeidelbergSoftware GmbH,Englerstrae 3,D-W6900 Heidelberg,Telefon 06221-300002,Telefax 06221-300389.Alle Rechte vorbehalten.Programmautor: Dietmar Rabich.Entwickelt mit Pure-Pascal.bUhrRsc|> x? A ?R`@C?>@?Z @#BZQ~pg|f 80TV݀ ?`   c Uw`@ " @  5UO @@ DA@@@>)⚪0@ DA@@@@@@ @UOwpx@!@ DA@@@!  @ |@#@  Gd U G@ ?  O cTVs"п 87|>?{33?s1{p`pL08 ~_>; D^ ?<??? "J  z @" J@ A i?@@AJ@ $ A ?@@" J@ $P# @ "J %P#  @ DJ  & 8F PpDD0w,< bHZ3Q k%0#X)}!!!!!!!                                    !!""#######                           !!!!!!!"""""""            """"""##$$%%&&&&&&##$$%%                    !"                     !"#$%&''''''''' ' ' ' ' ''''''''''                         !"" " " """"""#$%&'''''''''                                       !!! !""" ""### ##$ %%     ! !!""" "#                                             !!!""""""#########$$$$$       !!!"""###                                                                   ! !!!!!!!!!!!" """""""""""# #$ $                           !!""##$$%%&           !!""##$$%                                                     !! !!"" """""""""######## #########$$$$$$$$ $$$$$$$$$%%%%%%%%&&&&&&&&''''''''' ' '''''''''''                                                 !!!!!! Das Ziel des Spieles ist es, so lange wie mglich nicht an ein Hindernis zu stoen oder sich in den eigenen Krper zu beien. Gesteuert wird der Wurm mit den Cursortasten. Die Geschwindigkeit kann ber die Funktionstasten geregelt werden: F1=schnell, F2=etwas langsamer... F10=langsam. Um kurzzeitig Gas zu geben, kann man die linke SHIFT-Taste drcken. Mit Druck auf die Escape-Taste kann das Spiel beendet werden. Mit 'a' kann die Animation abgeschaltet werden. Dadurch wird der Wurm, vor allem, wenn er schon etwas lnger ist, wieder schneller. Durch erneuten Druck auf 'a' schaltet man die Animation wieder ein. Durch Druck auf die UNDO-Taste kann der Bildschirm abgeschaltet werden (BIC-Taste - Boss Is Coming: Es erscheinen 25 Bomben). Dadurch kann man vortuschen, man sei in einer Textverarbeitung gewesen und diese mal wieder abgestrzt. Durch Druck auf die Leertaste geht es jedoch weiter. Man hat zu Beginn des Spieles drei Leben. Es kann fr das Spiel eine beliebige Hintergrundgrafik eingebunden werden. Voraussetzung ist allerdings, da diese monochrom mit 640*400 Punkten unter dem Namen BLUTO.DOO vorliegt. program wurmie; {$X+} {$I-} (* Diese Programm war ursprnglich ein Basic-Listing. Es wurde in Pure Pascal umgesetzt. Es darf somit nicht als vorbildliche Programmierung unter Pascal gelten, es ist jedoch auch interessant, wie ein ursprngliches Basic-Listing umgesetzt werden kann. Das typische ist meist die groe Anzahl globaler Variablen. Das das Spiel ganz unterhaltsam ist, wurde es Pure Pascal beigelegt, vielleicht findet sich ja doch die eine oder andere ntzliche Routine. Oliver Buchmann, Juni 1992 *) uses crt, gem, tos, geminit; type sondertasten = (lshift, lshift_ctrl, keine_sondertaste); type untergrund = (frei, mauer1, mauer2, futter, exit); m_modus = (m_aus, m_an); const max_hind = 4800; (* max 1280*960 *) var screenmfdb, bild, sprites, hintergrund : MFDB; xmax, ymax, bitplanes, level, futtertyp, verzoegerung, plus, zaehler, max_aepfel, lives, count_hind, laenge, anz_aepfel, alt_richtungx, richtungx, alt_richtungy, richtungy : integer; startxpos, startypos, new_x_pos, new_y_pos, fehlernr : integer; fatal, midres, schluss, fertig, animate, exit_draw : boolean; wurmx, wurmy : ARRAY[0..max_hind] OF INTEGER; levels : ARRAY[0..20] OF INTEGER; Spieler : ARRAY[0..21] OF string; Punkte : ARRAY[0..21] OF LONGINT; screen : ARRAY[0..80] OF ARRAY[0..60] OF untergrund; anz_hind : ARRAY[1..12] OF INTEGER; anz_hind2 : ARRAY[1..12] OF INTEGER; hindernisx, hindernisy, hindernisx2, hindernisy2 : ARRAY [1..12] OF ARRAY[0..max_hind] OF INTEGER; speicherbedarf, start_time, max_zeit : longint; rect_kopf, rect_koerper, rect_m_koerper : ARRAY[0..6] OF array_8; rect_futter, rect_m_futter : ARRAY[0..9] OF array_8; rect, rect_exit, rect_mauer, rect_m_kopf, koordinaten : array_8; infostr : array[0..1300] of char; function clock : longint; var oldsupstack: longint; begin oldsupstack:=Super(nil); (*Nun sind wir im Supervisor-Modus*) clock:=longint(pointer($4BA)^); Super(pointer(oldsupstack)); (*Und nun sind wir wieder zurck.*) end; procedure maus(modus : m_modus); begin if modus=m_an then graf_mouse( M_ON, NIL ) (* Maus an *) else graf_mouse( M_OFF, NIL ); (* Maus aus *) end; procedure holebildspeicher; begin bild.fd_addr:=Malloc(speicherbedarf); hintergrund.fd_addr:=Malloc(speicherbedarf); sprites.fd_addr:=malloc(speicherbedarf); screenmfdb.fd_addr:=NIL; screenmfdb.fd_w:=xmax*16; screenmfdb.fd_h:=ymax*16; screenmfdb.fd_wdwidth:=40; screenmfdb.fd_stand:=0; screenmfdb.fd_nplanes:=bitplanes; if (bild.fd_addr=nil) or (hintergrund.fd_addr=nil) or (sprites.fd_addr=nil) then begin fatal:=true; fehlernr:=6; end; end; procedure gib_bildspeicher_wieder_frei; begin mfree(bild.fd_addr); mfree(hintergrund.fd_addr); mfree(sprites.fd_addr); end; procedure bildkonvert(var zielmfdb : mfdb); var mymfdbsrc: MFDB; begin mymfdbsrc.fd_addr:=zielmfdb.fd_addr; mymfdbsrc.fd_w:=640; mymfdbsrc.fd_h:=400; mymfdbsrc.fd_wdwidth:=40; mymfdbsrc.fd_stand:=1; mymfdbsrc.fd_nplanes:=1; zielmfdb.fd_w:=xmax*16; zielmfdb.fd_h:=ymax*16; zielmfdb.fd_wdwidth:=40; zielmfdb.fd_stand:=0; zielmfdb.fd_nplanes:=1; vr_trnfm(vdihandle,mymfdbsrc,zielmfdb); end; procedure first_init; var i : integer; begin fehlernr:=0; xmax:=(workout[0]+1) div 16; (* Auflsung horiz./16 *) ymax:=(workout[1]+1) div 16; (* Auflsung vert./16 *) if xmax>80 then xmax:=80; (* nur bis normale Grossbildschimrgrsse *) if ymax>60 then ymax:=60; (* s.o. *) if ymax<25 then midres:=true; (* ST - Mittel *) if xmax<40 then begin fatal:=true; fehlernr:=1; end; vq_extnd(vdihandle, 1, workout); bitplanes := workout[4]; speicherbedarf:=xmax*(ymax+1); speicherbedarf:=bitplanes*32*speicherbedarf; FOR i:=1 TO 20 DO begin Spieler[i]:=' '; Punkte[i]:=0; levels[i]:=0; end; Randomize; end; PROCEDURE spiel_init; BEGIN animate:=TRUE; plus:=1; zaehler:=0; max_aepfel:=0; lives:=3; verzoegerung:=5; Punkte[21]:=0; level:=1; futtertyp:=1; count_hind:=1; END; procedure bild_lesen(filename:string; adresse:pointer); var Fhandle : integer; begin Fhandle := Fopen(filename,0); if Fhandle>=0 then begin Fread( Fhandle, 32000, adresse ); Fclose (Fhandle); end; end; procedure sprites_lesen; var error, Fhandle : integer; filename: string; begin filename := 'wurm.dat'; Fhandle := Fopen(filename,0); if Fhandle>=0 then begin Fread( Fhandle, 4000, sprites.fd_addr ); error := Fclose (Fhandle); if error<>0 then begin fatal:=true; fehlernr:=2; end; bildkonvert(sprites); end else begin fatal:=true; fehlernr:=3; end; end; procedure rastercopy(x1,y1,x2,y2,x3,y3,x4,y4 : integer; m1, m2 : mfdb); var pxyarray: ARRAY_8; colind: ARRAY_2; begin pxyarray[0]:=x1; pxyarray[1]:=y1; pxyarray[2]:=x2; pxyarray[3]:=y2; pxyarray[4]:=x3; pxyarray[5]:=y3; pxyarray[6]:=x4; pxyarray[7]:=y4; vro_cpyfm(vdihandle,s_only,pxyarray,m1,m2); end; PROCEDURE put_hintergrundbild; var pxyarray: ARRAY_8; colind: ARRAY_2; BEGIN rastercopy(0,0,xmax*16-1,ymax*16-1,0,0,xmax*16-1,ymax*16-1, bild,screenmfdb); END; procedure showbild; var mymfdbscreen: MFDB; pxyarray: ARRAY_8; colind: ARRAY_2; begin mymfdbscreen.fd_addr:=NIL; rastercopy(0,0,639,399,0,0,639,399,bild,mymfdbscreen); end; PROCEDURE hiscore; var i, j, pos:integer; sorted : boolean; begin sorted:=false; highvideo; clrscr; pos:=0; IF Punkte[21]>Punkte[20] then begin write('Gib Deinen Namen ein : '); readln(spieler[21]); FOR i:=1 TO 20 do begin if not sorted then begin IF Punkte[21]>Punkte[i] then begin pos:=i; FOR j:=20 DOWNTO i do begin Punkte[j]:=Punkte[j-1]; spieler[j]:=spieler[j-1]; levels[j]:=levels[j-1]; end; spieler[i]:=spieler[21]; Punkte[i]:=Punkte[21]; levels[i]:=level; sorted:=true; end; end; end; end; clrscr; gotoxy(20,2); write('Pos.'); gotoxy(26,2); write('Name'); gotoxy(50,2); write('Punktezahl'); gotoxy(70,2); write('Level'); FOR i:=1 to 20 do begin if i=pos then highvideo else lowvideo; gotoxy(22,i+3); write(i);write(' '); gotoxy(26,i+3); write(spieler[i]:20); gotoxy(50,i+3); write(punkte[i]); gotoxy(70,i+3); write(levels[i]); end; gotoxy(60,25); write('Drcke Taste...'); repeat until keypressed; lowvideo; Punkte[21]:=0; schluss:=TRUE; end; procedure pause; begin delay(verzoegerung*10); end; PROCEDURE put_screen(modus : boolean); var t1, t2 : integer; BEGIN for t1:=0 to xmax-1 do begin for t2:=0 to ymax-1 do begin if (modus=true) or (screen[t1][t2]<>frei) then begin rastercopy(t1*16,t2*16,t1*16+15,t2*16+15,t1*16,t2*16,t1*16+15,t2*16+15, hintergrund, screenmfdb); end; end; end; END; procedure put_sprite_modus(x, y : integer; koordinaten : array_8; modus : integer); begin koordinaten[4]:=x*16; koordinaten[5]:=y*16; koordinaten[6]:=koordinaten[4]+15; koordinaten[7]:=koordinaten[5]+15; vro_cpyfm( vdiHandle, modus, koordinaten, sprites, screenmfdb ); end; procedure put_sprite(x, y : integer; koordinaten : array_8); begin koordinaten[4]:=x*16; koordinaten[5]:=y*16; koordinaten[6]:=koordinaten[4]+15; koordinaten[7]:=koordinaten[5]+15; vro_cpyfm( vdiHandle, S_OR_D, koordinaten, sprites, screenmfdb ); end; procedure put_maske(x, y : integer; koordinaten : array_8); begin koordinaten[4]:=x*16; koordinaten[5]:=y*16; koordinaten[6]:=koordinaten[4]+15; koordinaten[7]:=koordinaten[5]+15; vro_cpyfm( vdiHandle, S_AND_D, koordinaten, sprites, screenmfdb ); end; procedure baue_hindernis; var i : integer; begin FOR i:=1 TO anz_hind[count_hind] DO begin IF (hindernisx[count_hind,i]<=xmax) AND (hindernisy[count_hind,i]<=ymax) THEN begin screen[hindernisx[count_hind,i],hindernisy[count_hind,i]]:=mauer1; put_sprite_modus(hindernisx[count_hind,i],hindernisy[count_hind,i], rect_mauer, S_ONLY); END; END; FOR i:=1 TO anz_hind2[count_hind] DO begin IF (hindernisx2[count_hind,i]<=xmax) AND (hindernisy2[count_hind,i]<=ymax) THEN begin screen[hindernisx2[count_hind,i],hindernisy2[count_hind,i]]:=mauer2; put_sprite_modus(hindernisx2[count_hind,i],hindernisy2[count_hind,i], rect_mauer, S_ONLY); put_sprite_modus(hindernisx2[count_hind,i],hindernisy2[count_hind,i], rect_mauer, S_XOR_D); put_sprite_modus(hindernisx2[count_hind,i],hindernisy2[count_hind,i], rect_mauer, NOT_SORD); END; END; count_hind:=count_hind+1; if count_hind=13 then count_hind:=1; end; procedure setze_futter; var i, j : integer; zufall : real; begin max_aepfel:=0; repeat i:=system.random(xmax); j:=system.random(ymax-1)+1; IF (i<>startxpos-1) AND (j<>startypos) and (i<>startxpos) THEN begin IF screen[i,j]=frei THEN begin put_maske(i,j,rect_m_futter[futtertyp]); put_sprite(i,j,rect_futter[futtertyp]); screen[i,j]:=futter; max_aepfel:=max_aepfel+1; end; end; until (max_aepfel=level*10) or (max_aepfel>150); max_zeit:=max_aepfel*10; end; procedure helptext; var st : string; y, i, j, k, ypos : integer; warte : longint; begin if midres then ypos:=6 else ypos:=12; st:=''; for i:=1 to xmax*2 do st:=st+infostr[i]; st:=st+' '; FOR i:=xmax*16 downto -7 do begin warte:=clock; repeat until clock-warte=1; v_gtext( vdihandle, i, ypos, st); end; st:=''; for i:=2 to 1123 do begin if Bconstat(2)<>-1 then begin for j:=i to i+xmax*2 do st:=st+infostr[j]; for k:=1 downto -6 do begin warte:=clock; repeat until clock-warte=1; v_gtext( vdihandle, k, ypos, st); end; st:=''; end; end; st:=''; for i:=0 to xmax*2 do st:=st+' '; v_gtext(vdihandle,0,ypos,st); end; function ermittle_taste : longint; VAR Taste : longint; BEGIN Taste:=0; if Bconstat(2)=-1 then begin Taste:=Bconin(2); taste:=taste div 65536; end; ermittle_taste:=taste; end; PROCEDURE Zeige_Punkte; VAR str : string; BEGIN gotoxy(1,1); Write('Wurmie '); write('Leben : ',lives,' '); write('Bonus : ',max_zeit-(clock-start_time) div 200,' '); write('Hiscore : ',punkte[1],' '); write('Punkte : ',punkte[21],' '); write('Level : ',level,' '); END; procedure beenden; forward; PROCEDURE init2; var button : integer; leer:string; begin leer:=' '; gotoxy(1,1);Write(leer); schluss:=FALSE; richtungx:=1; richtungy:=0; zaehler:=0; plus:=1; startxpos:=xmax div 2; startypos:=12; new_x_pos:=startxpos+1; new_y_pos:=startypos; wurmx[1]:=startxpos; wurmy[1]:=startypos; if midres=true then begin startypos:=5; new_y_pos:=5; wurmy[1]:=5; end; repeat maus(m_an); button:=form_alert( 1, '[3][Kann es losgehen ? ][Ja|Info|Ende]' ); maus(m_aus); IF button=2 THEN helptext; IF button=3 THEN beenden; until button<>2; start_time:=clock; end; procedure level_init; var i, j : integer; begin FOR i:=0 TO xmax DO begin FOR j:=0 TO ymax DO screen[i,j]:=frei; END; FOR i:=0 TO xmax*ymax DO begin wurmx[i]:=0; wurmy[i]:=0; END; exit_draw:=false; laenge:=1; anz_aepfel:=0; baue_hindernis; Setze_Futter; init2; end; procedure beenden; var button : integer; BEGIN if Punkte[21]>punkte[20] then hiscore; level:=1; futtertyp:=1; count_hind:=1; lives:=3; maus(m_an); button:=form_alert( 2, '[3][ Nochmal? ][ JA | NEIN ]' ); maus(m_aus); if button=1 then begin put_screen(true); spiel_init; level_init; end else begin maus(m_an); form_alert( 1, '[1][ Bye, Bye ][So isses]' ); maus(m_aus); schluss:=true; end; end; function ermittle_sondertasten : sondertasten; var status : INTEGER; BEGIN status:=Kbshift(-1); IF status>15 then status:=status-16; case status of 2 : ermittle_sondertasten:=lshift; 6 : ermittle_sondertasten:=lshift_ctrl; else ermittle_sondertasten:=keine_sondertaste; end; end; procedure geschafft; BEGIN Punkte[21]:=Punkte[21]+max_zeit-(clock-start_time) div 200; maus(m_an); form_alert( 1, '[1][ Geschafft ][ Yeah ]' ); maus(m_aus); level:=level+1; futtertyp:=futtertyp+1; IF futtertyp=10 THEN futtertyp:=1; put_screen(false); level_Init; fertig:=FALSE; end; procedure put_hintergrund(x, y : integer); var rect:array_8; begin rect[0]:=x*16; rect[1]:=y*16; rect[2]:=rect[0]+15; rect[3]:=rect[1]+15; rect[4]:=x*16; rect[5]:=y*16; rect[6]:=rect[4]+15; rect[7]:=rect[5]+15; vro_cpyfm( vdiHandle, S_ONLY, rect, hintergrund, screenmfdb ); end; PROCEDURE neuaufbau; var i, j : integer; begin FOR i:=0 TO xmax-1 do begin FOR j:=0 TO ymax-1 do begin case screen[i,j] of frei: put_hintergrund(i,j); mauer1: put_sprite_modus(i,j,rect_mauer,s_only); mauer2 : begin put_sprite_modus(i,j,rect_mauer,s_only); put_sprite_modus(i,j,rect_mauer,6); put_sprite_modus(i,j,rect_mauer,8); end; futter : begin put_hintergrund(i,j); put_maske(i,j,rect_m_futter[futtertyp]); put_sprite(i,j,rect_futter[futtertyp]); end; exit : begin put_sprite_modus(i,j,rect_exit,s_only); exit_draw:=TRUE; end; end; end; end; end; procedure bic; var i : integer; pxyarray:array_4; begin clrscr; pxyarray[0]:=0; pxyarray[1]:=0; pxyarray[2]:=xmax*16-1; pxyarray[3]:=ymax*16-1; vsf_interior( vdihandle,2 ); vsf_style( vdihandle,4 ); v_bar( vdihandle, pxyarray); FOR i:=0 TO 24 do put_sprite_modus(i,ymax div 2,rect_futter[8],s_only); repeat repeat until KeyPressed; until Readkey = #32; put_screen(true); neuaufbau; FOR i:=1 TO laenge do begin IF wurmy[i]>0 then begin put_hintergrund(wurmx[i],wurmy[i]); put_sprite_modus(wurmx[i],wurmy[i],rect_m_koerper[1],1); put_sprite_modus(wurmx[i],wurmy[i],rect_koerper[1],7); end; end; end; procedure taste_auswerten; var t : longint; button: integer; begin if ermittle_sondertasten<>lshift then pause; t:=ermittle_taste; CASE t OF 1 : (* Esc zum Beenden *) begin repeat maus(m_an); button:=form_alert( 1, '[3][Hyperwurm | beenden? ][Ja|Nein|Info]' ); maus(m_aus); IF button=1 THEN beenden else if button=3 then helptext else schluss:=FALSE; until button<>3; end; 98 : if ermittle_sondertasten=lshift_ctrl THEN begin Punkte[21]:=Punkte[21]-max_zeit-(clock-start_time) div 200; (* Shift-Ctrl-Help, um Level zu beenden *) fertig:=TRUE; geschafft; END else helptext; 97 : bic; 30 : animate:=NOT(animate); (* 'a' schaltet Animation ab *) 77 : begin richtungx:=1; richtungy:=0; end; 75 : begin richtungx:=-1; richtungy:=0; end; 80 : begin richtungy:=1; richtungx:=0; end; 72 : begin richtungy:=-1; richtungx:=0; end; END; IF ((t>58) AND (t<69)) THEN (* Tempo durch Funktionstasten *) verzoegerung := t-59; alt_richtungx:=richtungx; alt_richtungy:=richtungy; IF alt_richtungx+richtungx=0 THEN richtungx:=alt_richtungx; IF alt_richtungy+richtungy=0 THEN richtungy:=alt_richtungy; end; PROCEDURE get_screen; BEGIN rastercopy(0,0,xmax*16-1,ymax*16-1,0,0,xmax*16-1,ymax*16-1,screenmfdb,hintergrund); END; procedure sprite_init; VAR i : INTEGER; j : untergrund; BEGIN rect_mauer[0]:=0; rect_mauer[1]:=34; rect_mauer[2]:=15; rect_mauer[3]:=34+15; rect_exit[0]:=136; rect_exit[1]:=34; rect_exit[2]:=136+14; rect_exit[3]:=34+14; FOR i:=0 TO 6 DO begin rect_kopf[i][0]:=i*17; rect_kopf[i][1]:=0; rect_kopf[i][2]:=rect_kopf[i][0]+15; rect_kopf[i][3]:=rect_kopf[i][1]+15; END; FOR i:=0 TO 6 DO begin rect_koerper[i][0]:=i*17+17; rect_koerper[i][1]:=34; rect_koerper[i][2]:=rect_koerper[i][0]+15; rect_koerper[i][3]:=rect_koerper[i][1]+15; END; FOR i:=0 TO 6 DO begin rect_m_koerper[i][0]:=i*17+119; rect_m_koerper[i][1]:=1; rect_m_koerper[i][2]:=rect_m_koerper[i][0]+15; rect_m_koerper[i][3]:=rect_m_koerper[i][1]+15; END; rect_futter[1][0]:=0; rect_futter[2][0]:=447; rect_futter[3][0]:=579; rect_futter[4][0]:=405; rect_futter[5][0]:=292; rect_futter[6][0]:=361; rect_futter[7][0]:=489; rect_futter[8][0]:=255; rect_futter[9][0]:=535; rect_futter[1][1]:=17; for i:=2 to 9 do rect_futter[i][1]:=0; rect_m_futter[1][0]:=237; rect_m_futter[2][0]:=466; rect_m_futter[3][0]:=598; rect_m_futter[4][0]:=425; rect_m_futter[5][0]:=314; rect_m_futter[6][0]:=340; rect_m_futter[7][0]:=512; rect_m_futter[8][0]:=366; rect_m_futter[9][0]:=555; rect_m_futter[1][1]:=0; rect_m_futter[2][1]:=0; rect_m_futter[3][1]:=0; rect_m_futter[4][1]:=0; rect_m_futter[5][1]:=22; rect_m_futter[6][1]:=22; rect_m_futter[7][1]:=0; rect_m_futter[8][1]:=22; rect_m_futter[9][1]:=0; FOR i:=1 TO 9 DO begin rect_futter[i][2]:=rect_futter[i][0]+15; rect_futter[i][3]:=rect_futter[i][1]+15; rect_m_futter[i][2]:=rect_m_futter[i][0]+15; rect_m_futter[i][3]:=rect_m_futter[i][1]+15; END; FOR i:=0 TO 6 DO begin rect_kopf[i][2]:=rect_kopf[i][0]+15; rect_kopf[i][3]:=rect_kopf[i][1]+15; rect_koerper[i][2]:=rect_koerper[i][0]+15; rect_koerper[i][3]:=rect_koerper[i][1]+15; rect_m_koerper[i][1]:=0; rect_m_koerper[i][2]:=rect_m_koerper[i][0]+15; rect_m_koerper[i][3]:=rect_m_koerper[i][1]+15; END; rect_m_kopf:=rect_m_koerper[1]; END; procedure lade_hindernis_daten; type feld = array[0..6000] of byte; feldptr = ^feld; var i, j, k, Fhandle, error : integer; Filename : string; f : feld; ptr : feldptr; begin ptr:=@f; filename := 'wurm.lev'; Fhandle := Fopen(filename,0); if Fhandle>=0 then begin Fread( Fhandle, 5654, ptr ); error := Fclose (Fhandle); if error<>0 then begin fatal:=true; fehlernr:=4; end; end else begin fatal:=true; fehlernr:=5; end; for i:=1 to 12 do begin anz_hind[i]:=(integer(f[i*4-4]))*256+integer(f[i*4-3]); anz_hind2[i]:=(integer(f[i*4-2]))*256+integer(f[i*4-1]); end; k:=48; for i:=1 to 12 do begin for j:=1 to anz_hind[i] do begin hindernisx[i,j]:=f[k]; hindernisy[i,j]:=f[k+1]; if midres then hindernisy[i,j]:=hindernisy[i,j] div 2; k:=k+2; end; for j:=1 to anz_hind2[i] do begin hindernisx2[i,j]:=f[k]; hindernisy2[i,j]:=f[k+1]; if midres then hindernisy2[i,j]:=hindernisy2[i,j] div 2; k:=k+2; end; end; for i:=4531 to 5653 do infostr[i-4530]:=chr(f[i]); end; procedure laden; var i, drive : integer; pfad : string; dateiname : Text; error : longint; begin drive:=Dgetdrv; pfad:=''; pfad:=pfad+char(drive+65)+':\paswurm.hsc'; Assign(dateiname,pfad); Reset(dateiname); error:=IOResult; if error=0 then begin for i:=1 to 20 do begin readln(dateiname,spieler[i]); readln(dateiname,punkte[i]); readln(dateiname,levels[i]); end; close(dateiname); end else begin for i:=1 to 20 do begin spieler[i]:=''; punkte[i]:=0; levels[i]:=0; end; end; end; procedure speichern; var i, drive : integer; pfad : string; dateiname : Text; begin drive:=Dgetdrv; pfad:=''; pfad:=pfad+char(drive+65)+':\paswurm.hsc'; Assign(dateiname,pfad); ReWrite(dateiname); for i:=1 to 20 do begin writeln(dateiname,spieler[i]); writeln(dateiname,punkte[i]); writeln(dateiname,levels[i]); end; close(dateiname); end; procedure tot; VAR i:INTEGER; BEGIN FOR i:=1 TO laenge DO begin put_hintergrund(wurmx[i],wurmy[i]); put_maske(wurmx[i],wurmy[i],rect_m_koerper[6]); put_sprite(wurmx[i],wurmy[i],rect_koerper[6]); screen[wurmx[i]][wurmy[i]]:=frei; END; FOR i:=1 TO laenge DO begin put_hintergrund(wurmx[i],wurmy[i]); wurmx[i]:=0; wurmy[i]:=0; END; schluss:=TRUE; lives:=lives-1; end; procedure zeichne_exit; var i, j : integer; begin FOR i:=5 TO xmax-5 do begin IF (exit_draw=FALSE) THEN begin FOR j:=5 TO ymax-5 do begin IF (exit_draw=FALSE) THEN begin IF screen[i,j]=frei then begin put_sprite_modus(i, j, rect_exit, S_ONLY); screen[i,j]:=exit; exit_draw:=true; end; end; end; end; end; end; PROCEDURE berechne_neue_position; BEGIN new_x_pos:=new_x_pos+richtungx; new_y_pos:=new_y_pos+richtungy; IF new_x_pos=xmax THEN new_x_pos:=0; IF new_y_pos=ymax THEN new_y_pos:=1; IF new_x_pos=-1 THEN new_x_pos:=xmax-1; IF new_y_pos=0 THEN new_y_pos:=ymax-1; END; PROCEDURE bewege; VAR i,j:INTEGER; BEGIN berechne_neue_position; IF (screen[new_x_pos,new_y_pos]=mauer1) or (screen[new_x_pos,new_y_pos]=mauer2) THEN begin maus(m_an); form_alert( 1, '[1][ Das kostet | | ein Leben ][ MIST ]'); maus(m_aus); tot; if lives=-1 then begin maus(m_an); form_alert( 1, '[1][ Das wars | dann wohl | ][JAWOLL]'); maus(m_aus); beenden; end else begin neuaufbau; init2; end END; if (schluss=false) and (fertig=false) then begin if screen[new_x_pos,new_y_pos]<>frei then begin case screen[new_x_pos,new_y_pos] of exit: begin put_hintergrund(new_x_pos,new_y_pos); fertig:=TRUE; geschafft; end; futter: begin screen[new_x_pos,new_y_pos]:=frei; laenge:=laenge+1; Punkte[21]:=Punkte[21]+20; anz_aepfel:=anz_aepfel+1; end; end; end else begin if wurmy[1]>0 then put_hintergrund(wurmx[1],wurmy[1]); screen[wurmx[1],wurmy[1]]:=frei; FOR i:=0 TO laenge-1 DO begin wurmx[i]:=wurmx[i+1]; wurmy[i]:=wurmy[i+1]; end; end; END; wurmx[laenge]:=new_x_pos; wurmy[laenge]:=new_y_pos; screen[new_x_pos,new_y_pos]:=mauer1; IF anz_aepfel=max_aepfel THEN begin IF (exit_draw=FALSE) THEN zeichne_exit; end; END; (* bewege*) PROCEDURE Zeichne_Wurm; VAR i:INTEGER; BEGIN IF (animate=TRUE) THEN begin zaehler:=zaehler+plus; IF zaehler=6 THEN plus:=-1; IF zaehler=0 THEN plus:=1; FOR i:=1 TO laenge-1 DO begin if wurmy[i]>0 then begin put_hintergrund(wurmx[i],wurmy[i]); put_maske(wurmx[i],wurmy[i],rect_m_koerper[zaehler]); put_sprite(wurmx[i],wurmy[i],rect_koerper[zaehler]); end; END; if wurmy[laenge]>0 then begin put_hintergrund(wurmx[laenge],wurmy[laenge]); put_maske(wurmx[laenge],wurmy[laenge],rect_m_kopf); put_sprite(wurmx[laenge],wurmy[laenge],rect_kopf[zaehler]); end; end ELSE begin if wurmy[laenge]>0 then begin put_hintergrund(wurmx[laenge],wurmy[laenge]); put_maske(wurmx[laenge],wurmy[laenge],rect_m_kopf); put_sprite(wurmx[laenge],wurmy[laenge],rect_kopf[zaehler]); end; IF laenge>1 THEN begin if wurmy[laenge-1]>0 then begin put_hintergrund(wurmx[laenge-1],wurmy[laenge-1]); put_maske(wurmx[laenge-1],wurmy[laenge-1],rect_m_koerper[0]); put_sprite(wurmx[laenge-1],wurmy[laenge-1],rect_koerper[0]); end; end; END; END; procedure clipping(i : integer); var px : array_4; begin px[0]:=0; px[1]:=0; px[2]:=xmax*16-1; px[3]:=ymax*16-1; vs_clip( vdihandle, i, px); end; begin if initgem=true then begin graf_mouse(ARROW, NIL); maus(m_aus); clrscr; first_init; holebildspeicher; if fehlernr<>6 then begin sprites_lesen; bild_lesen('BLUTO.DOO',bild.fd_addr); bildkonvert(bild); bildkonvert(hintergrund); hintergrund.fd_nplanes:=bitplanes; hintergrund.fd_wdwidth:=xmax; clipping(1); showbild; spiel_init; get_screen; sprite_init; lade_hindernis_daten; if fatal=false then begin Laden; level_init; REPEAT if frac((clock-start_time) / 200)<0.1 then Zeige_punkte; (* nur ca. jede Sekunde die Anzeige eneuern *) Zeichne_wurm; taste_auswerten; bewege; UNTIL schluss=TRUE; hiscore; Speichern; put_screen(true); end else begin maus(m_an); case fehlernr of 1 : form_alert( 1, '[3][ Der Wurm luft nicht | in dieser Auflsung ][Abbruch]' ); 2 : form_alert( 1, '[3][ Fehler beim Schlieen | der WURM.DAT-Datei ][Abbruch]' ); 3 : form_alert( 1, '[3][ Datei WURM.DAT | nicht gefunden ][Abbruch]' ); 4 : form_alert( 1, '[3][ Fehler beim Schlieen | der WURM.LEV-Datei ][Abbruch]' ); 5 : form_alert( 1, '[3][ Datei WURM.LEV | nicht gefunden ][Abbruch]' ); else form_alert( 1, '[3][ Fehler bei der | Initialisierung ][Abbruch]' ); end; maus(m_aus); end; end else form_alert( 1, '[3][ Kein Speicher mehr frei ][Abbruch]' ); end; clipping(0); maus(m_an); gib_bildspeicher_wieder_frei; end."""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""'""""""""""""""""""""""""""""""""""""""""<興"""""""""""""""""""""""""""""""""""y""""""""""""""""""""""""""""""""""""""""?"""""""""""""""""""""""""""""""""'""""""""""""""""""""""""""""""""""""""""<~~?""""""""""""""""""""""""""""""""xU?""""""""""""""""""""""""""""""""""""""""?0Up""""""""""""""""""""""""""""""'?Up"""""""""""""""""""""""""""""""""""""""<UUp興?"""""""""""""""""""""""""""""8UU"""""""""""""""""""""""""""""""""""""""09Wꫀ"""""""""""""""""""""""""""""(W""""""""""""""""""""""""""""""""""""""" >~?~?~?"""""""""""""""""""""""z""""""U_""""""""""""""""""""""""""""""""""""""">=U:"""""""""""""""""""""'""""""5U""""""""/"""""""""""""""""""""""""""<@:(5U興ȈTa:""""""""""""""""""""z*""""?5U"""""""'"""""""""""""""""""""""""""P|:  Ȉ|=WȋPP""""""""""""""""""' ""#߇"""""#"#"""""""""""""""""""""""""""=DDG|~ ~TTU?~"""""""""""""""""z " " #"#U""""/"#~"""""""""""""""""""""""""""??Ux? TTT?"""""""""""""""'~"x""""".?""""""""""""""""""""""""""?T@T@T@T` (((興Ȉ;TTT??""""""""""""""z3***?"""#""""""""""""""""""""""""""""""3PPP 3   ?UȈP3PPPwA""""""""""""' 3 7Uw?"""/"""""c""""""""""""""""""""""""""=DsDDDL3? 3?W?8TsTTU_1`~""""""""""""" 3" " "/"?""/"""" ~""""""""""""""""""""""""""@3?90?3?舉 TsTTlWp??""""""""""""0f0""<b"""(?"""""""""""""""""""""""""T@sT@TOTwW?G` (()3?(ȈT3T\Y? 0?"""""""""""",*3*.x<??"""0""""y"""""""""""""""""""""""""P3PW8\p? 3##&:P3RWW` A""""""""""""# 3 #z!#0?"""",> "'c"""""""""""""""""""""""""DsDp < 8sTx|8~""""""""""""" 3" p8>`>"""""#< """""""""""""""""""""""""@38x`x<0?3 x $sT^~@"""""""""""""2~#"#""`/""""""""""""""""""""""""@sT@Wp?@ ǀ ((8?0O興T3Tw_< ~""""""""""""",*3*p=?>#"0<""""""""""""""""""""""""P3Px<_x 3 <z/~ȏȈ T3P^}W@A"""""""""""""# 3 ''#@b",b""""""""""""""""""""""""sDD`   >8@8sT|80`~""""""""""""""?" ;p ">0"# """"""""""""""""""""""""@?x80>??  TWT~""""""""""""""0x~"#""/"""""""""""""""""""""""pT@UT@>?@((|?0@興 0TpT `~""""""""""""""*0*8:*"s# """"""""""""""""""""""" 0P^8P1800 /p ȈȜp 0WtT @p<A"""""""""""""""0 # ">@c b"""""""""""""""""""""""pDDG`'  <@8T|TU0`~"""""""""""""""" >" #"'0> ?"""""""""""""""""""""""0??  tTTTU{~8G"""""""""""""""*xx~"#0o/""""""""""""""""""""""4@T@T\T@ ((/+?`|@興TTW_ `"""""""""""""""(**/*"c0 """""""""""""""""""""" PPPq0   ?Ȉ TTU8N>A"""""""""""""""" /?":@| xb""""""""""""""""""""""DD~?`8 8@8TT0p`?""""""""""""""""" "".0x ?""""""""""""""""""""""0? `TT ~ <@"""""""""""""""" ?~"'$x`/"""""""""""""""""""""0T@TX>?@ (;<?`0@興Tx `""""""""""""""""**|#0 """"""""""""""""""""" P>0 ?ȉȌ Up^@""""""""""""""""" /"8#X| b"""""""""""""""""""""D8x8 ~ȸx@8p`?""""""""""""""""""""8"p z?"""""""""""""""""""""80Ȉ88>|8~a@""""""""""""""""""""""x~"c`"/""""""""""""""""""""p8?p@ <>8?`0@興0p `"""""""""""""""""""""" pr#80 z"w#""""""""""""""""""""103݁`ȸ ww@x0@"""""""""""""""""""""#@<2"` 'wb""""""""""""""""""""`8` <<~|>00wx?80]?"""""""""""""""""""""# :"0>"`ww?""""""""""""""""""""8= wp7~ """""""""""""""""""""">"$'wx>""/"""""""""""""""""""`?<1?ww|興x`}x""""""""""""""""""""""x`"#"x7ww"""#"""""""""""""""""""<p=pΈx7w0x߀""""""""""""""""""""""/8""C't~""""?"""""""""""""""""""n= wv <""""""""""""""""""""""""""xww"""#"""""""""""""""""""""| ?ݏww~"""""""""""""""""""""""/~""#w~""""?""""""""""""""""""""""?|?~??""""""""""""""""""""""""#>?"""""#""""""""""""""""""""""""?@?Ȉx#"""""""""""""""""""""""""?"">""""?"""""""""""""""""""""""""p8?"""""""""""""""""""""""""<"""""#"""""""""""""""""""""""""""@` 8~"""""""""""""""""""""""""/? :~""""/""""""""""""""""""""""""""""08?8?8"""""""""""""""""""""""""#x~:?""""""""""""""""""""""""""""""""~0<?8ȈȈx?0""""""""""""""""""""""""""2'/"""""""""""""""""""""""""""""""<0xx?p""""""""""""""""""""""""#<@b#"""""""""""""""""""""""""""""""""`x` Ȉ0@~"""""""""""""""""""""""?"#x`""""""""""""""""""""""""""""""""""""  Ȉp0""""""""""""""""""""""":"""p""""""""""""""""""""""""""""""""""""80|x~~""""""""""""""""""""""".""".<?""""""""""""""""""""""""""""""""""""x?<"""""""""""""""""""""""#""#x"""""""""""""""""""""""""""""""""""""Ȉ@8`x"""""""""""""""""""#"""< UUW_UWU_""""""""""""""""""""""""""0ꫪxUUW_UWU]xꫪ""""""""""""""""""/U]UWz"""#UUW_UWU]_"""""""""""""""""""""""""?ꫪ]U]UW\UUW_UWU]U8~ꫪ"""""""""""""""""/]U]UWV""""<UUW_UWU]U^"""""""""""""""""""""""""ꫪU]U]UWW""""""""""""""""""""#UW_UWU]U]""""""""""""""""""""""""ꫪU]U]UWUȈUW_UWU]U]xꫪ""""""""""""""""/WU]U]UWUb""""':'UW_UWU]U]^""""""""""""""""""""""""ꫪWU]U]UWUxUW_UWU]U]^z|ꫪ""""""""""""""""WU]U]UWUZ"""""?"#UW_UWU]U]W"""""""""""""""""""""""ꫪxꫪWU]U]UWU\|Ȉ"""""""""""""""#WU]U]UWU^""""""<""^U]U]U"""""""""""""""""""""""~ꫪUW^U]U]Uh?ꫪ"""""""""""""""'UWU]U]UWUW""""""?""?UW^U]U]Ur"""""""""""""""""""""""ꫪUWU]U]UWUWȈȈW^U]U]Ux>ꫪ"""""""""""""""-UWU]U]UWUW"""""""/""/W^U]U]UZ"""""""""""""""""""""""pꫪUWU]U]UWUWxW^U]U]UX?"""""""""""""""-UWU]U]UWUWz""""""#"""#"""""""""""""""""""""""ꫪW_UWU]U]UXꫪ"""""""""""""""-UWU\ U]UW^"""""/"""""W_UWU]U]UZ"""""""""""""""""""""""?ꫪUWU\ U]UWW興W_UWU]U]UXꫪ"""""""""""""""-UWU\ U]UWW""""""""""?W_UWU]U]UZ"""""""""""""""""""""""?ꫪUWU\ U]UWUȈW_UWU]U]UX"""""""""""""""-UWU\ U]UWU"""""""?""?"""""""""""""""""""""""興W_UWU]U]UX?ꫪ"""""""""""""""/"""""""#""'W_UWU]U]UZ"""""""""""""""""""""""?ꫪUWU]U]U]UWU\興W_UWU]U]UX"""""""""""""""-UWU]U]U]UWUV"""?""""/""#W_UWU]U]UZ"""""""""""""""""""""""UWU]U]U]UWUWW_UWU]U]UX"""""""""""""""-UWU]U]U]UWUW""""""""""W_UWU]U]UZ"""""""""""""""""""""""~UWU]U]U]UWUWȈ?"""""""""""""""/"""""#""""?_U_U]U]UZ"""""""""""""""""""""""UWU]U]U]UWUWx_U_U]U]UX"""""""""""""""-UWU]U]U]UWUW^""""?""""#W_U_U]U]UZ"""""""""""""""""""""""ꫪUWU]U]U]UWUW^ȈW_U_U]U]UXꫪ"""""""""""""""-UWU]U]U]UWUWW"""?""""?W_U_U]U]UZ#"""""""""""""""""""""ꫪUWU]U]U]UWUWWUW"""""""""""""""-UWU]U]U]UWUWU""'"""#"""""""""""""""""""""ꫪ戈UUW_U_U]U]_ꫪ(~"""""""""""""""-UWU]U]U\UWUq"#""""?UUW_U_U]U_>"""""""""""""""""""""ꫪ"?UWU]U]U\UWUxhȈ]UUW_U_U]U0?ꫪ """""""""""""""-UWU]U]U\UWU\"""""#U]UUW_U_U]_O"""""""""""""""""""" ꫪUWU]U]U\UWU^uU]UUW_U_U_Ȉꫪ*"""""""""""""""-UWU]U]U\UWUW""""?uU]UU""""""""""""""""""""0> W_U_U^?ꫪ """""""""""""""/"#_UuU]UUW_U_U_""""""""""""""""""""ꫪ?UWU]U]U_UWUWUWx_UuU]UUW_U_U_> ꫪ~"""""""""""""""-UWU]U]U_UWUWUWU_UuU]UUW_U_U]~""""""""""""""""""""ꫪUWU]U]U_UWUWUWWU_UuU]UUW_U_U]p?ꯪꫪ"""""""""""""""-UWU]U]U_UWUWUWUWU_UuU]UUW""""""""""""""""""""UWU]U_?Ȉꫪ"""""""""""""""/U_UWUWUWWUWU_UpUUW_U_U]^"""""""""""""""""""""ꫪ?UWU]U]U_UWUWUWUWUWU_UpUUW_U_U]Wꫪ"""""""""""""""-UWU]U]U_UWUWUW_UWUWU_UpUUW_U_U]U""""""""""""""""""""""ꫪUWU]U]U_UWUWUW_UWUWU_UpUUW_U_U]U䈈ꫪT"""""""""""""""-UWU]U]U_UWUWUW_UWUWU_UpUUW_U_U]U"""""""""""""""""""""""TUWU]U_"""""""""""""""/UW_UWUWU_UuU]UUW_U_U]U_"""""""""""""""""""""""ꫪU]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_ꫪ"""""""""""""""/U]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_"""""""""""""""""""""""ꫪU]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_ꫪ"""""""""""""""/U]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_"""""""""""""""""""""""ꫪU]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_ꫪ"""""""""""""""/U]U]U_UWUWUW_UWUWU_UuU]UUW_U_U]U_"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""{ ------------------------------------------------------------ } { UNIT GEMINIT } { (c) 1992 Pure Software GmbH } { } { the unit GemInit performs all init and exit stuff needed to } { execute a gem program. } { ------------------------------------------------------------ } unit GemInit; interface {$X+} uses gem; var vdiHandle, aesHandle : Integer; apID : Integer; workIn : workin_ARRAY; workOut : workout_ARRAY; charWidth, charHeight : Integer; boxWidth, boxHeight : Integer; function InitGem : Boolean; procedure ExitGem; implementation { ------------------------------------------------------------ } { this procedure ends up a gem program. } { ------------------------------------------------------------ } procedure ExitGem; begin v_clsvwk( vdiHandle ); appl_exit; end; { ------------------------------------------------------------ } { this function initalizes the gem. it returns true if it was } { successful. } { ------------------------------------------------------------ } function InitGem : Boolean; var i : Integer; begin apID := appl_init; if apID >= 0 then begin aesHandle := graf_handle( charWidth, charHeight, boxWidth, boxHeight ); workIn[0] := aesHandle; for i := 1 to workin_max - 1 do workIn[i] := 1; workIn[10] := 2; v_opnvwk( workIn, vdiHandle, workOut ); if vdiHandle <= 0 then begin appl_exit; InitGem := False; end else InitGem := True; end else InitGem := False; end; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT GEMINIT } { (c) 1992 Pure Software GmbH } { } { the unit GemInit performs all init and exit stuff needed to } { execute a gem program. } { ------------------------------------------------------------ } unit GemInit; interface {$X+} uses gem; var vdiHandle, aesHandle : Integer; apID : Integer; workIn : workin_ARRAY; workOut : workout_ARRAY; charWidth, charHeight : Integer; boxWidth, boxHeight : Integer; function InitGem : Boolean; procedure ExitGem; implementation { ------------------------------------------------------------ } { this procedure ends up a gem program. } { ------------------------------------------------------------ } procedure ExitGem; begin v_clsvwk( vdiHandle ); appl_exit; end; { ------------------------------------------------------------ } { this function initalizes the gem. it returns true if it was } { successful. } { ------------------------------------------------------------ } function InitGem : Boolean; var i : Integer; begin apID := appl_init; if apID >= 0 then begin aesHandle := graf_handle( charWidth, charHeight, boxWidth, boxHeight ); workIn[0] := aesHandle; for i := 1 to workin_max - 1 do workIn[i] := 1; workIn[10] := 2; v_opnvwk( workIn, vdiHandle, workOut ); if vdiHandle <= 0 then begin appl_exit; InitGem := False; end else InitGem := True; end else InitGem := False; end; end. { ============================================================ } { ------------------------------------------------------------ } { UNIT GEMINIT } { (c) 1992 Pure Software GmbH } { } { the unit GemInit performs all init and exit stuff needed to } { execute a gem program. } { ------------------------------------------------------------ } unit GemInit; interface {$X+} uses gem; var vdiHandle, aesHandle : Integer; apID : Integer; workIn : workin_ARRAY; workOut : workout_ARRAY; charWidth, charHeight : Integer; boxWidth, boxHeight : Integer; function InitGem : Boolean; procedure ExitGem; implementation { ------------------------------------------------------------ } { this procedure ends up a gem program. } { ------------------------------------------------------------ } procedure ExitGem; begin v_clsvwk( vdiHandle ); appl_exit; end; { ------------------------------------------------------------ } { this function initalizes the gem. it returns true if it was } { successful. } { ------------------------------------------------------------ } function InitGem : Boolean; var i : Integer; begin apID := appl_init; if apID >= 0 then begin aesHandle := graf_handle( charWidth, charHeight, boxWidth, boxHeight ); workIn[0] := aesHandle; for i := 1 to workin_max - 1 do workIn[i] := 1; workIn[10] := 2; v_opnvwk( workIn, vdiHandle, workOut ); if vdiHandle <= 0 then begin appl_exit; InitGem := False; end else InitGem := True; end else InitGem := False; end; end. { ============================================================ } (* PurePascalClock *) (* Copyright 1992 by Thomas Hoffmann *) (* Application Systems Heidelberg Software GmbH *) {$X+} (*Funktionsaufrufe ohne Verwendung des Resultats erlaubt*) program PurePascalClock; uses gem,tos; type GRECT= record g_x,g_y,g_w,g_h: integer; end; CONST ALL= 0; TIME= 1; var phys_handle,handle: integer; (*Handles fr GEM und VDI*) whandle: integer; (*Window-Handle fr Uhr*) gl_wchar,gl_hchar: integer; (*Breite bzw. Hhe eines Zeichens*) gl_wbox,gl_hbox: integer; max_x,max_y: integer; (*grte x bzw y Koordinate*) appl_id,menu_id: integer; (*Applikationsnummer,Meneintrag*) title: string[19]; (*Titelzeile fr Fenster*) events: integer; stunde,minute,sekunde: integer; oldsec,oldmin,oldhour: integer; secdif,mindif,hourdif: integer; work_in: workin_array; work_out: workout_array; wx,wy,ende: integer; redrawflag: boolean; function max(a,b:integer):integer; begin if a>b then max:=a else max:=b end; function min(a,b:integer):integer; begin if ax) and (h>y) then rc_intersect:=true else rc_intersect:=false; end; procedure mouse_on; begin graf_mouse(M_ON,NIL); end; procedure mouse_off; begin graf_mouse(M_OFF,NIL); end; function open_vwork: boolean; var i: integer; begin for i:=0 to 9 do work_in[i]:=1; work_in[10]:=2; phys_handle:=graf_handle(gl_wchar,gl_hchar,gl_wbox,gl_hbox); work_in[0]:=phys_handle; handle:=phys_handle; v_opnvwk(work_in,handle,work_out); open_vwork:=TRUE end; procedure close_vwork; begin v_clsvwk(handle) end; procedure calcpoint(w,h,i:integer;var x,y:integer;s:integer); begin x:=w div 2+trunc((w div 2-10-s)*sin(2*i*PI/60)); y:=h div 2+trunc((h div 2-10-s)*cos(PI+2*i*PI/60)) end; procedure gettime(var hour,min,sec:integer); var time: word; begin time:=Tgettime; hour:=(time shr 11) and $1F; if hour>12 then hour:=hour-12; min:=(time shr 5) and $3F; sec:=(time and $1F)*2; end; procedure showtime; var x,y: integer; xyarray: ptsin_array; work: GRECT; begin wind_get(whandle,WF_WORKXYWH,work.g_x,work.g_y,work.g_w,work.g_h); xyarray[0]:=work.g_x+work.g_w div 2; xyarray[1]:=work.g_y+work.g_h div 2; calcpoint(work.g_w,work.g_h,oldsec,x,y,secdif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_color(handle,WHITE); vsl_width(handle,1); v_pline(handle,2,xyarray); if minute <> oldmin then begin calcpoint(work.g_w,work.g_h,oldmin,x,y,mindif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_width(handle,3); vsl_color(handle,WHITE); v_pline(handle,2,xyarray); end; if (minute<>oldmin) or (minute mod 12=0) or (stunde<>oldhour) then begin vsl_width(handle,5); calcpoint(work.g_w,work.g_h,oldhour*5+oldmin div 12,x,y,hourdif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_color(handle,WHITE); v_pline(handle,2,xyarray); end; calcpoint(work.g_w,work.g_h,sekunde,x,y,secdif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_color(handle,BLACK); vsl_width(handle,1); v_pline(handle,2,xyarray); calcpoint(work.g_w,work.g_h,minute,x,y,mindif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_width(handle,3); v_pline(handle,2,xyarray); calcpoint(work.g_w,work.g_h,stunde*5+minute div 12,x,y,hourdif); xyarray[2]:=work.g_x+x; xyarray[3]:=work.g_y+y; vsl_width(handle,5); v_pline(handle,2,xyarray); end; procedure redrawwindow(what:integer); var box,work: GRECT; clip: Array_4; i,x,y: integer; fak: real; begin if whandle<=0 then exit; mouse_off; vswr_mode(handle,MD_REPLACE); wind_get(whandle,WF_WORKXYWH,work.g_x,work.g_y,work.g_w,work.g_h); wind_get(whandle,WF_FIRSTXYWH,box.g_x,box.g_y,box.g_w,box.g_h); secdif:=min(work.g_w,work.g_h) div 2; mindif:=trunc(secdif/5); hourdif:=trunc(secdif/3); secdif:=trunc(secdif/6); gettime(stunde,minute,sekunde); if oldsec=sekunde then inc(sekunde); while (box.g_w>0) and (box.g_h>0) do begin if rc_intersect(work,box) then begin clip[0]:=box.g_x; clip[1]:=box.g_y; clip[2]:=box.g_x+box.g_w-1; clip[3]:=box.g_y+box.g_h-1; vs_clip(handle,1,clip); case what of ALL: begin vsf_color(handle,WHITE); vsf_perimeter(handle,0); vsf_interior(handle,FIS_SOLID); vr_recfl(handle,clip); vsf_color(handle,BLACK); vsf_perimeter(handle,1); for i:=0 to 11 do begin calcpoint(work.g_w,work.g_h,i*5,x,y,0); v_circle(handle,work.g_x+x,work.g_y+y,2); end; showtime; end; TIME: showtime; end end; wind_get(whandle,WF_NEXTXYWH,box.g_x,box.g_y,box.g_w,box.g_h); end; oldsec:=sekunde; oldmin:=minute; oldhour:=stunde; mouse_on; end; procedure open_window; var calc: GRECT; begin if whandle <=0 then begin whandle:=wind_create(NAME or CLOSER or MOVER or SIZER,0,0,max_x+1,max_y+1); if whandle<=0 then exit; title:=' Pure Pascal Clock '; wind_set(whandle,WF_NAME,hiword(@title[1]),loword(@title[1]),0,0); mouse_off; if wx=-1 then begin wind_calc(WC_BORDER,CLOSER OR MOVER,100,100,170,170, calc.g_x,calc.g_y,calc.g_w,calc.g_h); wx:=(max_x-calc.g_w) div 2; wy:=16+(max_y-calc.g_h) div 2; end; wind_open(whandle,wx,wy,170,170); mouse_on; end else wind_set(whandle,WF_TOP,0,0,0,0); end; function handle_message(var pipe:array_8):integer; var dummy: integer; begin case pipe[0] of WM_REDRAW: redrawwindow(ALL); WM_TOPPED: wind_set(whandle,WF_TOP,0,0,0,0); WM_CLOSED: begin if pipe[3]=whandle then begin wind_get(whandle,WF_WORKXYWH,wx,wy,dummy,dummy); wind_close(whandle); wind_delete(whandle); whandle:=0; end; if appflag then begin handle_message:=1; exit; end else events:=MU_MESAG; end; WM_MOVED: if pipe[3]=whandle then wind_set(whandle,WF_CURRXYWH,pipe[4],pipe[5],pipe[6],pipe[7]) else redrawflag:=TRUE; WM_SIZED: if pipe[3]=whandle then begin if pipe[6]<100 then pipe[6]:=100; if pipe[7]<100 then pipe[7]:=100; wind_set(whandle,WF_CURRXYWH,pipe[4],pipe[5],pipe[6],pipe[7]); redrawwindow(ALL); end; AC_OPEN: if pipe[4]=menu_id then begin open_window; events:=MU_MESAG or MU_TIMER; end; AC_CLOSE: if pipe[3]=menu_id then whandle:=0; end; handle_message:=0; end; function event_loop:integer; var event,x,y,kstate,key,clicks,state,quit: integer; pipe: array_8; begin quit:=0; repeat event:=evnt_multi(events,258,3,0,0,0,0,0,0,0,0,0,0,0, pipe,1000,0,x,y,state,kstate,key,clicks); wind_update(BEG_UPDATE); if (event and MU_TIMER)<>0 then begin if redrawflag then begin redrawwindow(ALL); redrawflag:=FALSE end else redrawwindow(TIME); end; if (event and MU_MESAG)<>0 then quit:=handle_message(pipe); wind_update(END_UPDATE); until quit>0; event_loop:=quit; end; begin appl_id:=appl_init; if appl_id<>-1 then begin if open_vwork then begin max_x:=work_out[0]; max_y:=work_out[1]; redrawflag:=FALSE; wx:=-1; if appflag=FALSE then begin menu_id:=menu_register(appl_id,' Pure Pascal Clock '); events:=MU_MESAG end else begin graf_mouse(0,nil); events:=MU_MESAG or MU_TIMER; open_window end; repeat ende:=event_loop until ende=1; close_vwork end; appl_exit end end.(* PurePascalEyes *) (* Copyright 1992 by Thomas Hoffmann *) (* Application Systems Heidelberg Software GmbH *) program PurePascalEyes; {$X+} (*Funktionsaufrufe ohne Verwendung des Resultats erlaubt*) uses gem; type GRECT= record g_x,g_y,g_w,g_h: integer; end; CONST ALL= 0; EYES= 1; var phys_handle,handle: integer; (*Handles fr GEM und VDI*) whandle: integer; (*Window-Handle fr Uhr*) gl_wchar,gl_hchar: integer; (*Breite bzw. Hhe eines Zeichens*) gl_wbox,gl_hbox: integer; max_x,max_y: integer; (*grte x bzw y Koordinate*) appl_id,menu_id: integer; (*Applikationsnummer,Meneintrag*) work_in: workin_array; work_out: workout_array; title: string[19]; (*Titelzeile fr Fenster*) events: integer; (*Ereigniskombination fr evnt_multi*) oldx,oldy: integer; ende: integer; wx,wy: integer; function max(a,b:integer):integer; (*Maximum zweier Integerwerte ermitteln*) begin if a>b then max:=a else max:=b end; function min(a,b:integer):integer; (*Minimum zweier Integerwerte ermitteln*) begin if ax) and (h>y) then rc_intersect:=true else rc_intersect:=false; end; procedure mouse_on; begin graf_mouse(M_ON,NIL); end; procedure mouse_off; begin graf_mouse(M_OFF,NIL); end; function open_vwork: boolean; (*virtuelle Arbeitsstation ffnen*) var i: integer; begin for i:=0 to 9 do work_in[i]:=1; work_in[10]:=2; phys_handle:=graf_handle(gl_wchar,gl_hchar,gl_wbox,gl_hbox); work_in[0]:=phys_handle; handle:=phys_handle; v_opnvwk(work_in,handle,work_out); open_vwork:=TRUE end; procedure close_vwork; (*virtuelle Arbeitsstation schlieen*) begin v_clsvwk(handle) end; procedure setfillparams(color,perimeter,interior:integer); (*Parameter fr gefllte Flchen setzen*) begin vsf_color(handle,color); vsf_perimeter(handle,perimeter); vsf_interior(handle,interior); end; procedure redrawwindow(what:integer); (*Fensterinhalt auffrischen*) var box,work: GRECT; clip: Array_4; pmx,pmy,pmstate,pkstate: integer; xx,yy,zz,f,ff: real; procedure pupil(mx,my,x,y:integer); begin xx:=mx-(work.g_x+x); yy:=my-(work.g_y+y); zz:=sqrt(sqr(xx)+sqr(yy)); if zz<>0 then begin f:=9*xx/zz; ff:=19*yy/zz end else begin f:=0; ff:=0 end; v_circle(handle,work.g_x+x+trunc(f),work.g_y+y+trunc(ff),10); end; begin if whandle<=0 then exit; wind_get(whandle,WF_WORKXYWH,work.g_x,work.g_y,work.g_w,work.g_h); wind_get(whandle,WF_FIRSTXYWH,box.g_x,box.g_y,box.g_w,box.g_h); graf_mkstate(pmx,pmy,pmstate,pkstate); while (box.g_w>0) and (box.g_h>0) do begin if rc_intersect(work,box) then begin clip[0]:=box.g_x; clip[1]:=box.g_y; clip[2]:=box.g_x+box.g_w-1; clip[3]:=box.g_y+box.g_h-1; vs_clip(handle,1,clip); if what=ALL then begin mouse_off; setfillparams(WHITE,0,FIS_SOLID); vr_recfl(handle,clip); setfillparams(BLACK,1,FIS_HOLLOW); v_ellipse(handle,work.g_x+25,work.g_y+40,20,35); v_ellipse(handle,work.g_x+work.g_w-25,work.g_y+40,20,35); mouse_on; end; if (oldx<>pmx) or (oldy<>pmy) or (what=ALL) then begin mouse_off; setfillparams(WHITE,0,FIS_SOLID); pupil(oldx,oldy,25,40); pupil(oldx,oldy,work.g_w-25,40); setfillparams(BLACK,0,FIS_SOLID); pupil(pmx,pmy,25,40); pupil(pmx,pmy,work.g_w-25,40); mouse_on; end; end; wind_get(whandle,WF_NEXTXYWH,box.g_x,box.g_y,box.g_w,box.g_h); end; oldx:=pmx; oldy:=pmy; end; procedure open_window; (*Fenster ffnen*) var calc: GRECT; begin if whandle <=0 then begin whandle:=wind_create(NAME or CLOSER or MOVER,0,0,max_x+1,max_y+1); if whandle<=0 then exit; title:=' Eyes '#0; wind_set(whandle,WF_NAME,hiword(@title[1]),loword(@title[1]),0,0); mouse_off; if wx=-1 then begin wind_calc(WC_BORDER,CLOSER OR MOVER,100,100,100,100, calc.g_x,calc.g_y,calc.g_w,calc.g_h); wx:=(max_x-calc.g_w) div 2; wy:=16+(max_y-calc.g_h) div 2; end; wind_open(whandle,wx,wy,100,100); mouse_on; end else wind_set(whandle,WF_TOP,0,0,0,0); end; function handle_message(var pipe:array_8):integer; (*Messages abarbeiten*) var dummy: integer; begin case pipe[0] of WM_REDRAW: redrawwindow(ALL); WM_TOPPED: wind_set(whandle,WF_TOP,0,0,0,0); WM_CLOSED: begin if pipe[3]=whandle then begin wind_get(whandle,WF_WORKXYWH,wx,wy,dummy,dummy); wind_close(whandle); wind_delete(whandle); whandle:=0; end; if appflag then begin handle_message:=1; exit; end else events:=MU_MESAG; end; WM_MOVED: if pipe[3]=whandle then begin wind_set(whandle,WF_CURRXYWH,pipe[4],pipe[5],pipe[6],pipe[7]); redrawwindow(all); end; AC_OPEN: if pipe[4]=menu_id then begin open_window; events:=MU_MESAG or MU_TIMER; end; AC_CLOSE: if pipe[3]=menu_id then whandle:=0; end; handle_message:=0; end; function event_loop:integer; (*Ereignisschleife-das Herz des Programmes*) var event,x,y,kstate,key,clicks,state,quit: integer; pipe: array_8; begin quit:=0; repeat event:=evnt_multi(events,0,0,0,0,0,0,0,0,0,0,0,0,0, pipe,100,0,x,y,state,kstate,key,clicks); wind_update(BEG_UPDATE); if (event and MU_MESAG)<>0 then quit:=handle_message(pipe); if (event and MU_TIMER)<>0 then redrawwindow(EYES); wind_update(END_UPDATE); until quit>0; event_loop:=quit; end; begin appl_id:=appl_init; if appl_id<>-1 then begin if open_vwork then begin vswr_mode(handle,MD_REPLACE); max_x:=work_out[0]; max_y:=work_out[1]; wx:=-1; oldx:=-1; oldy:=-1; if appflag=FALSE then begin menu_id:=menu_register(appl_id,' Pure Pascal Eyes '); events:=MU_MESAG end else begin graf_mouse(0,nil); events:=MU_MESAG or MU_TIMER; open_window end; repeat ende:=event_loop until ende=1; close_vwork end; appl_exit end end.AUSWERTUNGBESTOKBEGINNERNEXTPROFIS NEXTTEXT PROFTEXT LEONAME1NAME2NAME3ZEIT1ZEIT2ZEIT3NAME0ZEIT0BESTDELCOLORSUSERIMGRBHNORMRBHSELRBLNORMRBLSELCBHNORMCBHSELCBLNORMCBLSELSMILESUNOOHBLUBSTEINMINEFAHNELEERINFO SMILE2 SUN2 OOH2 BLUB2 STEIN2MINE2FAHNE2LEER2INFO2(* Resource Datei Indizes fr MSWEEPER *) CONST AUSWERTUNG = 0; (* Formular/Dialog *) BESTOK = 3; (* BUTTON in Baum AUSWERTUNG *) BEGINNER = 6; (* BOX in Baum AUSWERTUNG *) NEXT = 7; (* BOX in Baum AUSWERTUNG *) PROFIS = 8; (* BOX in Baum AUSWERTUNG *) NEXTTEXT = 10; (* STRING in Baum AUSWERTUNG *) PROFTEXT = 11; (* STRING in Baum AUSWERTUNG *) LEO = 12; (* BOX in Baum AUSWERTUNG *) NAME1 = 16; (* FTEXT in Baum AUSWERTUNG *) NAME2 = 17; (* FTEXT in Baum AUSWERTUNG *) NAME3 = 18; (* FTEXT in Baum AUSWERTUNG *) ZEIT1 = 22; (* FTEXT in Baum AUSWERTUNG *) ZEIT2 = 23; (* FTEXT in Baum AUSWERTUNG *) ZEIT3 = 24; (* FTEXT in Baum AUSWERTUNG *) NAME0 = 25; (* FTEXT in Baum AUSWERTUNG *) ZEIT0 = 26; (* FTEXT in Baum AUSWERTUNG *) BESTDEL = 28; (* BUTTON in Baum AUSWERTUNG *) COLORS = 30; (* BOX in Baum AUSWERTUNG *) USERIMG = 1; (* Formular/Dialog *) RBHNORM = 1; (* IMAGE in Baum USERIMG *) RBHSEL = 2; (* IMAGE in Baum USERIMG *) RBLNORM = 3; (* IMAGE in Baum USERIMG *) RBLSEL = 4; (* IMAGE in Baum USERIMG *) CBHNORM = 5; (* IMAGE in Baum USERIMG *) CBHSEL = 6; (* IMAGE in Baum USERIMG *) CBLNORM = 7; (* IMAGE in Baum USERIMG *) CBLSEL = 8; (* IMAGE in Baum USERIMG *) SMILE = 0; (* Freies Icon *) SUN = 1; (* Freies Icon *) OOH = 2; (* Freies Icon *) BLUB = 3; (* Freies Icon *) STEIN = 4; (* Freies Icon *) MINE = 5; (* Freies Icon *) FAHNE = 6; (* Freies Icon *) LEER = 7; (* Freies Icon *) INFO = 8; (* Freies Icon *) SMILE2 = 9; (* Freies Icon *) SUN2 = 10; (* Freies Icon *) OOH2 = 11; (* Freies Icon *) BLUB2 = 12; (* Freies Icon *) STEIN2 = 13; (* Freies Icon *) MINE2 = 14; (* Freies Icon *) FAHNE2 = 15;(* PurePascalMineSweeper *) (* Copyright 1992 by Thomas Hoffmann *) (* Application Systems Heidelberg Software GmbH *) {$M 32768} (*fr Rekursion ausreichend Platz auf dem Stack reservieren*) {$X+} (*Funktionsaufrufe ohne Verwendung des Resultats erlaubt*) program PurePascalMineSweeper; uses gem,tos; type GRECT= record g_x,g_y,g_w,g_h: integer; end; element= record value: integer; flag: integer; end; redrawproctype= procedure(var box:GRECT;value,what:integer); {$I MSWEEPER.I } (*Konstantendefinitionen der RSC einbinden*) CONST GFLAG_CLOSE =-1; (*Einige Konstanten*) GFLAG_MARKED =11; GFLAG_ASK =9; GVAL_MINE =10; GVAL_NOMINE =0; DISP_MINES =0; DISP_TIME =1; DISP_SMILE =2; C_LEOS =0; C_ANFAENGER =1; C_FORTGESCHRITTENE=2; C_PROFIS =3; RBNORM =0; RBSEL =1; CBNORM =2; CBSEL =3; DCHECKBOX =$40; DRADIO =$60; var work_in: workin_array; work_out: workout_array; handle,phys_handle,f: integer; gl_hchar,gl_wchar,gl_hbox,gl_wbox: integer; max_x,max_y,appl_id,menu_id,gl_apid: integer; whandle,events,wx, wy: integer; title: string[20]; icon: array [0..8] of MFDB; button: array [0..3] of MFDB; checkblk, radioblk: userblk; dialog: AESTreePtr; gamearray: array[0..101,0..81] of element; zeilen,spalten,minen: integer; status,statusalt,time,markiert,offene_felder,actsmile: integer; oldtimer: longint; timeflag,gameflag,colorflag: boolean; ende: integer; function open_vwork: boolean; var i: integer; begin for i:=0 to 9 do work_in[i]:=1; work_in[10]:=2; phys_handle:=graf_handle(gl_wchar,gl_hchar,gl_wbox,gl_hbox); work_in[0]:=phys_handle; handle:=phys_handle; v_opnvwk(work_in,handle,work_out); open_vwork:=TRUE; end; procedure initicon(i:integer; var ptr:pointer); var mymfdbsrc: MFDB; bitbl: BITBLKPtr; begin bitbl:=ptr; mymfdbsrc.fd_addr:=bitbl^.bi_pdata; mymfdbsrc.fd_w:=21; mymfdbsrc.fd_h:=21 div f; mymfdbsrc.fd_wdwidth:=2; mymfdbsrc.fd_stand:=1; mymfdbsrc.fd_nplanes:=1; icon[i].fd_addr:=bitbl^.bi_pdata; icon[i].fd_w:=21; icon[i].fd_h:=21 div f; icon[i].fd_wdwidth:=2; icon[i].fd_stand:=0; icon[i].fd_nplanes:=1; vr_trnfm(handle,mymfdbsrc,icon[i]); end; procedure initbutton(o,i:integer; var ptr:pointer); var mymfdbsrc: MFDB; bitbl: BITBLKPtr; aesptr: AESTreePtr; begin aesptr:=ptr; bitbl:=aesptr^[o].ob_spec.bit_blk; mymfdbsrc.fd_addr:=bitbl^.bi_pdata; mymfdbsrc.fd_w:=16; mymfdbsrc.fd_h:=12 div f; mymfdbsrc.fd_wdwidth:=1; mymfdbsrc.fd_stand:=1; mymfdbsrc.fd_nplanes:=1; button[i].fd_addr:=bitbl^.bi_pdata; button[i].fd_w:=16; button[i].fd_h:=12 div f; button[i].fd_wdwidth:=1; button[i].fd_stand:=0; button[i].fd_nplanes:=1; vr_trnfm(handle,mymfdbsrc,button[i]); end; procedure showbutton(bu,x,y:integer); var mymfdbscreen: MFDB; pxyarray: ARRAY_8; colind: ARRAY_2; h: integer; begin if f>1 then h:=7 else h:=11; mymfdbscreen.fd_addr:=NIL; pxyarray[0]:=0; pxyarray[1]:=0; pxyarray[2]:=15; pxyarray[3]:=h; pxyarray[4]:=x; pxyarray[5]:=y; pxyarray[6]:=x+15; pxyarray[7]:=y+h; colind[0]:=BLACK; colind[1]:=WHITE; vrt_cpyfm(handle,MD_REPLACE,pxyarray,button[bu],mymfdbscreen,colind); end; function DrawRadio( dummy1, dummy2 : Pointer; parm: PARMBLKPtr) : Integer; var pxyarray: array_4; begin pxyarray[0]:=parm^.pb_xc; pxyarray[1]:=parm^.pb_yc; pxyarray[2]:=parm^.pb_wc; pxyarray[3]:=parm^.pb_hc; vs_clip(handle,0,pxyarray); if (parm^.pr_currstate and SELECTED)<>0 then showbutton(rbsel,parm^.pb_x,parm^.pb_y) else showbutton(rbnorm,parm^.pb_x,parm^.pb_y); DrawRadio:=parm^.pr_currstate and NOT(SELECTED); end; function DrawCheck( dummy1, dummy2 : Pointer; parm: PARMBLKPtr) : Integer; var pxyarray: array_4; begin pxyarray[0]:=parm^.pb_xc; pxyarray[1]:=parm^.pb_yc; pxyarray[2]:=parm^.pb_wc; pxyarray[3]:=parm^.pb_hc; vs_clip(handle,0,pxyarray); if (parm^.pr_currstate and SELECTED)<>0 then showbutton(cbsel,parm^.pb_x,parm^.pb_y) else showbutton(cbnorm,parm^.pb_x,parm^.pb_y); DrawCheck:=parm^.pr_currstate and NOT(SELECTED); end; procedure setuserdef(ptr: AESTreePtr); var ob: AESObjectPtr; obj, extype: integer; begin obj:=0; repeat inc(obj); ob:=@ptr^[obj]; extype:=ob^.ob_type shr 8; if extype=DCHECKBOX then begin checkblk.ub_code:=@DrawCheck; checkblk.ub_parm:=longint(ob^.ob_spec); ob^.ob_type:=G_USERDEF; ob^.ob_spec.user_blk:=@checkblk end else if extype=DRADIO then begin radioblk.ub_code:=@DrawRadio; radioblk.ub_parm:=longint(ob^.ob_spec); ob^.ob_type:=G_USERDEF; ob^.ob_spec.user_blk:=@radioblk; end until (ob^.ob_flags AND LASTOB)<>0 end; function rsrc_init: boolean; var offset: integer; var ptr: pointer; begin if rsrc_load('MSWEEPER.RSC')=1 then begin if f=2 then offset:=SMILE2-SMILE else offset:=0; rsrc_gaddr(R_IMAGEDATA,SMILE+offset,ptr); initicon(0,ptr); rsrc_gaddr(R_IMAGEDATA,SUN+offset,ptr); initicon(1,ptr); rsrc_gaddr(R_IMAGEDATA,OOH+offset,ptr); initicon(2,ptr); rsrc_gaddr(R_IMAGEDATA,BLUB+offset,ptr); initicon(3,ptr); rsrc_gaddr(R_IMAGEDATA,STEIN+offset,ptr); initicon(4,ptr); rsrc_gaddr(R_IMAGEDATA,MINE+offset,ptr); initicon(5,ptr); rsrc_gaddr(R_IMAGEDATA,FAHNE+offset,ptr); initicon(6,ptr); rsrc_gaddr(R_IMAGEDATA,LEER+offset,ptr); initicon(7,ptr); rsrc_gaddr(R_IMAGEDATA,INFO+offset,ptr); initicon(8,ptr); rsrc_gaddr(R_TREE,AUSWERTUNG,ptr); dialog:=ptr; setuserdef(dialog); rsrc_gaddr(R_TREE,USERIMG,ptr); if f=1 then begin initbutton(RBHNORM,rbnorm,ptr); initbutton(RBHSEL,rbsel,ptr); initbutton(CBHNORM,cbnorm,ptr); initbutton(CBHSEL,cbsel,ptr) end else begin initbutton(RBLNORM,rbnorm,ptr); initbutton(RBLSEL,rbsel,ptr); initbutton(CBLNORM,cbnorm,ptr); initbutton(CBLSEL,cbsel,ptr) end; rsrc_init:=TRUE end else rsrc_init:=FALSE end; procedure close_vwork; begin v_clsvwk(handle); end; function max(a,b:integer):integer; begin if ax) and (h>y) then rc_intersect:=true else rc_intersect:=false; end; procedure mouse_on; begin graf_mouse(M_ON,NIL); end; procedure mouse_off; begin graf_mouse(M_OFF,NIL); end; procedure showicon(ic,x,y,color:integer); var mymfdbscreen: MFDB; pxyarray: ARRAY_8; colind: ARRAY_2; begin mymfdbscreen.fd_addr:=NIL; pxyarray[0]:=0; pxyarray[1]:=0; pxyarray[2]:=20; pxyarray[3]:=20 div f; pxyarray[4]:=x; pxyarray[5]:=y; pxyarray[6]:=x+20; pxyarray[7]:=y+20 div f; colind[0]:=color; colind[1]:=WHITE; vrt_cpyfm(handle,MD_REPLACE,pxyarray,icon[ic],mymfdbscreen,colind); end; procedure display(var box:GRECT;wert,what:integer); var xyarray: array_4; function digital(wert:integer):string; var s: string[3]; i: integer; begin if wert<-99 then wert:=-99; if wert>999 then wert:=999; str(wert:3,s); for i:=1 to 3 do if (s[i]>='0') and (s[i]<='9') then s[i]:=chr(ord(s[i])-32); digital:=s; end; begin vsf_color(handle,BLACK); vsf_interior(handle,FIS_HOLLOW); vsf_perimeter(handle,1); vst_color(handle,RED); case what of DISP_MINES: begin xyarray[0]:=box.g_x+4; xyarray[1]:=box.g_y+4 div f; xyarray[2]:=xyarray[0]+26; xyarray[3]:=xyarray[1]+20 div f; v_bar(handle,xyarray); v_gtext(handle,xyarray[0]+2,xyarray[3]-4 div f,digital(wert)); end; DISP_TIME: begin xyarray[0]:=box.g_x+box.g_w-5-26; xyarray[1]:=box.g_y+4 div f; xyarray[2]:=xyarray[0]+26; xyarray[3]:=xyarray[1]+20 div f; v_bar(handle,xyarray); v_gtext(handle,xyarray[0]+2,xyarray[3]-4 div f,digital(wert)); end; DISP_SMILE: begin showicon(wert-SMILE,box.g_x+box.g_w div 2-10,box.g_y+4 div f,BLACK); actsmile:=wert; showicon(INFO,box.g_x+box.g_w-55,box.g_y+4 div f,BLUE); end; end; end; procedure initgamearray; var i,j,x,y: integer; begin case status of C_LEOS: begin zeilen:=8; spalten:=8; minen:=1; end; C_ANFAENGER: begin zeilen:=8; spalten:=8; minen:=10; end; C_FORTGESCHRITTENE: begin zeilen:=15; spalten:=16; minen:=35; end; C_PROFIS: begin zeilen:=15; spalten:=28; minen:=80; end; end; offene_felder:=0; markiert:=0; time:=0; for i:=0 to spalten+1 do for j:=0 to zeilen+1 do begin gamearray[i,j].value:=GVAL_NOMINE; gamearray[i,j].flag:=GFLAG_CLOSE; end; i:=0; while i0) and (box.g_h>0) do begin if rc_intersect(work,box) then begin clip[0]:=box.g_x; clip[1]:=box.g_y; clip[2]:=box.g_x+box.g_w-1; clip[3]:=box.g_y+box.g_h-1; vs_clip(handle,1,clip); redrawproc(work,value,what); end; wind_get(whandle,WF_NEXTXYWH,box.g_x,box.g_y,box.g_w,box.g_h); end; mouse_on; end; procedure drawgamearea(var work:GRECT;value,what:integer); var i,j: integer; xyarray: array_4; begin vsf_color(handle,WHITE); xyarray[0]:=work.g_x; xyarray[1]:=work.g_y; xyarray[2]:=work.g_x+work.g_w-1; xyarray[3]:=work.g_y+work.g_h-1; vr_recfl(handle,xyarray); display(work,value,DISP_SMILE); for i:=0 to spalten-1 do for j:=0 to zeilen-1 do drawbox(gamearray[i+1,j+1].flag,i,j); display(work,what,DISP_SMILE); end; function showelement(x,y:integer):integer; var i,j,n: integer; begin if gamearray[x+1,y+1].flag=GFLAG_CLOSE then begin inc(offene_felder); if gamearray[x+1,y+1].value=GVAL_MINE then begin redrawwindow(display,OOH,DISP_SMILE); events:=MU_MESAG or MU_BUTTON; for i:=0 to spalten-1 do for j:=0 to zeilen-1 do if gamearray[i+1,j+1].value=GVAL_MINE then begin drawbox(10,i,j); gamearray[i+1,j+1].flag:=GVAL_MINE end; showelement:=0; gameflag:=FALSE; exit; end; n:=0; for i:=0 to 2 do for j:=0 to 2 do if gamearray[x+i,y+j].value=GVAL_MINE then inc(n); drawbox(n,x,y); gamearray[x+1,y+1].flag:=n; if n=0 then begin for i:=0 to 2 do for j:=0 to 2 do if (x-1+i>=0) and (y-1+j>=0) and (x-1+i<=spalten-1) and (y-1+j<=zeilen-1) then showelement(x-1+i,y-1+j); end; end; showelement:=1; end; procedure einstellungen; var f: text; n0,n1,n2,n3,s: string; z0,z1,z2,z3,neu,res,status_alt: integer; function get_obj_state(t:AESTREEPtr;o:integer):integer; begin get_obj_state:=t^[o].ob_state; end; procedure set_obj_state(t:AESTreePtr;o,s:integer); begin t^[o].ob_state:=s; end; procedure set_obj_flags(t:AESTREEPtr;o,s:integer); begin t^[o].ob_flags:=t^[o].ob_flags or s; end; procedure del_obj_flags(t:AESTREEPtr;o,s:integer); begin t^[o].ob_flags:=t^[o].ob_flags and (t^[o].ob_flags xor s); end; function hndl_form(obj:integer):integer; var answer: integer; x,y,w,h: integer; procedure hide_form(obj:integer); begin form_center(dialog,x,y,w,h); form_dial(fmd_finish,x,y,w,h,x,y,w,h); end; procedure show_form(obj:integer); begin form_center(dialog,x,y,w,h); form_dial(fmd_start,x,y,w,h,x,y,w,h); objc_draw(dialog,0,max_depth,x,y,w,h); end; begin mouse_off; show_form(auswertung); mouse_on; answer:=form_do(dialog,0); hide_form(auswertung); set_obj_state(dialog, answer, get_obj_state(dialog,answer) and (not selected)); hndl_form:=answer; end; begin mouse_on; n0:='Unbekannt'; n1:=n0; n2:=n0; n3:=n0; z0:=999; z1:=999; z2:=999; z3:=999; assign(f,'MSWEEPER.INF'); {$I-} reset(f); if IOResult=0 then begin readln(f,n0); readln(f,z0); readln(f,n1); readln(f,z1); readln(f,n2); readln(f,z2); readln(f,n3); readln(f,z3); close(f) end; {$I+} neu:=-1; if ende<>3 then begin case status of C_LEOS: begin if min(time,z0)=time then begin n0:=''; z0:=time; neu:=NAME0; end; end; C_ANFAENGER: begin if min(time,z1)=time then begin n1:=''; z1:=time; neu:=NAME1; end; end; C_FORTGESCHRITTENE: begin if min(time,z2)=time then begin n2:=''; z2:=time; neu:=NAME2; end; end; C_PROFIS: begin if min(time,z3)=time then begin n3:=''; z3:=time; neu:=NAME3; end; end; end end; if max_x<320 then begin set_obj_state(dialog,NEXT,DISABLED); set_obj_state(dialog,PROFIS,DISABLED); set_obj_state(dialog,NEXTTEXT,DISABLED); set_obj_state(dialog,PROFTEXT,DISABLED); end; SetPtext(dialog,name0,n0); SetPtext(dialog,zeit0,tostr(z0)); SetPtext(dialog,name1,n1); SetPtext(dialog,zeit1,tostr(z1)); SetPtext(dialog,name2,n2); SetPtext(dialog,zeit2,tostr(z2)); SetPtext(dialog,name3,n3); SetPtext(dialog,zeit3,tostr(z3)); if neu<>-1 then set_obj_flags(dialog,neu,EDITABLE); if hndl_form(auswertung)=BESTDEL then begin n0:='Unbekannt'; n1:=n0; n2:=n0; n3:=n0; z0:=999; z1:=999; z2:=999; z3:=999 end else begin GetPtext(dialog,name0,n0); GetPtext(dialog,zeit0,s); val(s,z0,res); GetPtext(dialog,name1,n1); GetPtext(dialog,zeit1,s); val(s,z1,res); GetPtext(dialog,name2,n2); GetPtext(dialog,zeit2,s); val(s,z2,res); GetPtext(dialog,name3,n3); GetPtext(dialog,zeit3,s); val(s,z3,res) end; if neu <>-1 then del_obj_flags(dialog,neu,EDITABLE); assign(f,'MSWEEPER.INF'); {$I-} rewrite(f); if IOResult=0 then begin writeln(f,n0); writeln(f,z0); writeln(f,n1); writeln(f,z1); writeln(f,n2); writeln(f,z2); writeln(f,n3); writeln(f,z3); close(f); end; {$I+} if dialog^[COLORS].ob_state=SELECTED then colorflag:=TRUE else colorflag:=FALSE; status_alt:=status; if dialog^[BEGINNER].ob_state=SELECTED then status:=C_ANFAENGER else if dialog^[NEXT].ob_state=SELECTED then status:=C_FORTGESCHRITTENE else if dialog^[LEO].ob_state=SELECTED then status:=C_LEOS else status:=C_PROFIS; if status<>status_alt then begin wind_close(whandle); wind_delete(whandle); whandle:=0; initgamearray; wx:=-1; open_window; redrawwindow(display,SMILE,DISP_SMILE); timeflag:=FALSE; gameflag:=TRUE; end; mouse_off; end; procedure fertig; var offen,richtig,i,j: integer; begin if (offene_felder=spalten*zeilen) and (markiert=minen) then begin redrawwindow(display,SUN,DISP_SMILE); timeflag:=FALSE; gameflag:=FALSE; events:=MU_MESAG or MU_BUTTON; einstellungen; end; end; function mausclick(xpos,ypos,knopf:integer):integer; var x,y,i,j,open,wx,wy: integer; box: GRECT; xyarray: array_4; begin mausclick:=0; wind_get(whandle,WF_WORKXYWH,box.g_x,box.g_y,box.g_w,box.g_h); if (xpos-box.g_x-4>=0) and (ypos-box.g_y-32 div f>=0) then begin x:=(xpos-box.g_x-4) div 21; y:=(ypos-box.g_y-32 div f) div (21 div f); if (x>=0) and (x<=spalten-1) and (y>=0) and (y<=zeilen-1) and gameflag then begin if not timeflag then begin timeflag:=TRUE; events:=events or MU_TIMER; oldtimer:=getticks; end; xyarray[0]:=0; xyarray[1]:=0; xyarray[2]:=max_x; xyarray[3]:=max_y; vs_clip(handle,1,xyarray); mouse_off; if knopf=1 then begin if showelement(x,y)=1 then fertig end else begin case gamearray[x+1,y+1].flag of GFLAG_MARKED: begin gamearray[x+1,y+1].flag:=GFLAG_ASK; dec(markiert); dec(offene_felder); redrawwindow(display,minen-markiert,DISP_MINES); drawbox(gamearray[x+1,y+1].flag,x,y); end; GFLAG_ASK: begin gamearray[x+1,y+1].flag:=GFLAG_CLOSE; drawbox(gamearray[x+1,y+1].flag,x,y) end; GFLAG_CLOSE: begin gamearray[x+1,y+1].flag:=GFLAG_MARKED; inc(markiert); inc(offene_felder); redrawwindow(display,minen-markiert,DISP_MINES); drawbox(gamearray[x+1,y+1].flag,x,y); if markiert=minen then fertig; end; end; end; mouse_on; end; end else if (xpos>box.g_x+box.g_w div 2-11) and (xposbox.g_y+4 div f) and (yposbox.g_x+box.g_w-55) and (xposbox.g_y+4 div f) and (ypos0 then quit:=mausclick(x,y,state); if (event and MU_TIMER)<>0 then begin time:=integer((getticks-oldtimer) div 200); redrawwindow(display,time,DISP_TIME); end; if (event and MU_MESAG)<>0 then quit:=handle_message(pipe); wind_update(END_UPDATE); until quit>0; event_loop:=quit; end; begin appl_id:=appl_init; if appl_id<>-1 then begin if open_vwork then begin max_x:=work_out[0]-16; max_y:=work_out[1]; if max_y=199 then f:=2 else f:=1; if rsrc_init then begin wx:=-1; status:=C_ANFAENGER; system.randomize; initgamearray; colorflag:=TRUE; timeflag:=FALSE; gameflag:=TRUE; actsmile:=SMILE; if appflag=FALSE then begin menu_id:=menu_register(appl_id,' Minesweeper '); events:=MU_MESAG; end else begin graf_mouse(0,nil); events:=MU_MESAG or MU_BUTTON; open_window; end; repeat ende:=event_loop; if ende>1 then begin if ende=3 then begin statusalt:=status; mouse_off; einstellungen; mouse_on; if timeflag and gameflag and (statusalt=status) then events:=MU_MESAG or MU_BUTTON or MU_TIMER else begin events:=MU_MESAG or MU_BUTTON; timeflag:=FALSE end end else begin initgamearray; redrawwindow(drawgamearea,BLUB,SMILE); redrawwindow(display,minen-markiert,DISP_MINES); redrawwindow(display,time,DISP_TIME); redrawwindow(display,SMILE,DISP_SMILE); events:=MU_MESAG or MU_BUTTON; timeflag:=FALSE; gameflag:=TRUE; end; ende:=-1; end; until ende=1; close_vwork; end; end; appl_exit; end; end. ,ll|4$)  ,,1 l'  -`` `%    ' ` - <)))X t   ) @     *8  F  T  b - 8Ca lw       23|       p   l   h    <  h          D  p Minesweeper EinstellungenOKSpielmodusAnfngerFortgeschritteneProfisLeosBestzeitensec.sec.sec.sec.Bestzeiten lschenMinenanzahl - in Farbe!0123456789Anfnger: __________XXXXXXXXXX0123456789Fortgeschrittene: __________XXXXXXXXXX0123456789Profis: __________XXXXXXXXXX___Zeit: ___xxx___Zeit: ___xxx___Zeit: ___xxx0123456789Leos: __________XXXXXXXXXX___Zeit: ___xxxCopyright 1992 by ASHp~ &4BP^ 0     0 0'''' 0xxxx?          ??0 ($$"D!!"D$$(0 ??     ??8&d!&d8? @@   X@   @@ HH H HHp̉qUXUXUXUXUXUXUXUXH|?|Hpp     ̉HpH̉vUXUXUX|H?|Hpp| (* Freies Icon *) LEER2 = 16; (* Freies Icon *) INFO2 = 17; (* Freies Icon *) . s.. TETRAX PAS ZNProgram TetraX; (* Nach dem PC-Spiel Tetris von Spectrum Holobyte. Megamax Modula-2 Version von Heiko Annen Groeneveld. Pure Pascal-Version von Oliver Buchmann, Application Systems Heidelberg, basierend auf der Modula-2 Version von Herrn Groeneveld, der uns freundlicherweise gestattete, dieses Listing mitzuliefern. Ein kleines Beispiel, wie wenig Aufwand es macht, ein Modula-2-Listing auf Pure Pascal umzusetzen. Die nderungen erkennt man hauptschlich an den aus Faulheit klein geschriebenen 'begin's und 'end's und natrlich 'Writeln's. *) {$i-} (* eigene I/O-berprfung *) uses tos, crt; CONST XX = 30; Hoch = 22; Breit = 10; TYPE TEins = RECORD X,Y:INTEGER; END; TVier = ARRAY[1..3] OF TEins; TSteine = ARRAY[1..19] OF TVier; CharSet = SET OF CHAR; ScoreTable = ARRAY [1..10] OF RECORD Punkte: integer; Zeilen: integer; Name : string[3]; END; VAR Steine : TSteine; Art,OldA,nextart : INTEGER; Stein,OldSt : RECORD X,Y: INTEGER; END; Stop : BOOLEAN; KeinStein : BOOLEAN; Feld : ARRAY[-1..Breit+2] of array[-1..Hoch+2] OF BOOLEAN; Hoehe : INTEGER; C : CHAR; Lines,FAST : integer; Delay,D,H,K : integer; Score : integer; Level,Stapel : INTEGER; HallofFame : ScoreTable; NewScore : BOOLEAN; Filename : Text; verzoegerung : integer; PROCEDURE Initialisieren; VAR I,J:INTEGER; BEGIN Score:=0; FAST := 10; Delay := (10-Level) * 50; verzoegerung:=20; Randomize; ClrScr; GotoXY(1,1); Write('TetraX'); GotoXY(1,5); Write('Zeilen:'); GotoXY(1,7); Write('Punkte:'); GotoXY(1,8); Write('HiScore'); Lines:=0; GotoXY(9,5); Write(Lines:1); GotoXY(9,7); Write(Score:1); GotoXY(9,8); Write(HallofFame[1].Punkte:1); GotoXY(1,23);Write('1992 by Oliver Buchmann,'); GotoXY(1,24);Write(' H. A. Groeneveld'); gotoXY(60,24); write('Verzgerung : ',verzoegerung); FOR I:=1 TO Hoch DO begin GotoXY(XX+1,Hoch+2-I); Write('|'); GotoXY(XX+Breit*2+2,Hoch+2-I); Write('|'); END; Hoehe:=0; Steine[1][1].X := 1; Steine[1][1].Y := 0; Steine[1][2].X := 0; Steine[1][2].Y := 1; Steine[1][3].X := 1; Steine[1][3].Y := 1; Steine[2][1].X := 0; Steine[2][1].Y := 1; Steine[2][2].X := 0; Steine[2][2].Y := 2; Steine[2][3].X := 0; Steine[2][3].Y := 3; Steine[3][1].X := -1; Steine[3][1].Y := 0; Steine[3][2].X := 1; Steine[3][2].Y := 0; Steine[3][3].X := 2; Steine[3][3].Y := 0; Steine[4][1].X := -1; Steine[4][1].Y := 0; Steine[4][2].X := 0; Steine[4][2].Y := 1; Steine[4][3].X := 1; Steine[4][3].Y := 1; Steine[5][1].X := 1; Steine[5][1].Y := 0; Steine[5][2].X := 0; Steine[5][2].Y := 1; Steine[5][3].X := -1; Steine[5][3].Y := 1; Steine[6][1].X := 1; Steine[6][1].Y := 0; Steine[6][2].X := 0; Steine[6][2].Y := 1; Steine[6][3].X := 0; Steine[6][3].Y := 2; Steine[7][1].X := -1; Steine[7][1].Y := 0; Steine[7][2].X := 0; Steine[7][2].Y := 1; Steine[7][3].X := 0; Steine[7][3].Y := 2; Steine[8][1].X := 0; Steine[8][1].Y := 1; Steine[8][2].X := -1; Steine[8][2].Y := 1; Steine[8][3].X := -1; Steine[8][3].Y := 2; Steine[9][1].X := 0; Steine[9][1].Y := 1; Steine[9][2].X := 1; Steine[9][2].Y := 1; Steine[9][3].X := 1; Steine[9][3].Y := 2; Steine[10][1].X := -1; Steine[10][1].Y := 0; Steine[10][2].X := 1; Steine[10][2].Y := 0; Steine[10][3].X := 1; Steine[10][3].Y := 1; Steine[11][1].X := -1; Steine[11][1].Y := 1; Steine[11][2].X := -1; Steine[11][2].Y := 0; Steine[11][3].X := 1; Steine[11][3].Y := 0; Steine[12][1].X := 0; Steine[12][1].Y := 1; Steine[12][2].X := 0; Steine[12][2].Y := 2; Steine[12][3].X := -1; Steine[12][3].Y := 2; Steine[13][1].X := 0; Steine[13][1].Y := 1; Steine[13][2].X := 0; Steine[13][2].Y := 2; Steine[13][3].X := 1; Steine[13][3].Y := 2; Steine[14][1].X := -1; Steine[14][1].Y := -1; Steine[14][2].X := -1; Steine[14][2].Y := 0; Steine[14][3].X := 1; Steine[14][3].Y := 0; Steine[15][1].X := -1; Steine[15][1].Y := 0; Steine[15][2].X := 1; Steine[15][2].Y := 0; Steine[15][3].X := 1; Steine[15][3].Y := -1; Steine[16][1].X := -1; Steine[16][1].Y := 0; Steine[16][2].X := 1; Steine[16][2].Y := 0; Steine[16][3].X := 0; Steine[16][3].Y := 1; Steine[17][1].X := 0; Steine[17][1].Y := 1; Steine[17][2].X := 1; Steine[17][2].Y := 1; Steine[17][3].X := 0; Steine[17][3].Y := 2; Steine[18][1].X := 0; Steine[18][1].Y := 1; Steine[18][2].X := -1; Steine[18][2].Y := 1; Steine[18][3].X := 1; Steine[18][3].Y := 1; Steine[19][1].X := 0; Steine[19][1].Y := 1; Steine[19][2].X := -1; Steine[19][2].Y := 1; Steine[19][3].X := 0; Steine[19][3].Y := 2; FOR I:=-1 TO Hoch+2 DO begin FOR J:=-1 TO Breit+2 DO begin Feld[J][I]:=TRUE; END; END; FOR I:=1 TO Hoch DO begin FOR J:=1 TO Breit DO begin Feld[J][I]:=FALSE; END; END; KeinStein:=TRUE; END; procedure get_taste; VAR Taste : longint; BEGIN Taste:=0; c:=' '; if Bconstat(2)=-1 then begin Taste:=Bconin(2); taste:=taste div 65536; end; CASE Taste OF 77, 108 : begin (*rechts*) c:='6'; end; 75, 106 : begin (*links*) c:='4'; end; 80, 110 : begin (*unten*) c:='2'; end; 72, 107 : begin (*oben*) c:='5'; end; 57 : begin (*Space fr Pause*) c:='P'; end; 16, 1 : begin (* Esc oder Q zum Beenden *) c:='Q'; end; 74 : begin if verzoegerung>0 then verzoegerung:=verzoegerung-1; gotoXY(60,24); write('Verzgerung : ',verzoegerung,' '); end; 78 : begin if verzoegerung<50 then verzoegerung:=verzoegerung+1; gotoXY(60,24); write('Verzgerung : ',verzoegerung,' '); end; END; (* case *) end; PROCEDURE schaff_platz; var i : integer; BEGIN for i:=1 to 6 do BEGIN gotoxy(54,i);write(' '); END; END; PROCEDURE Abfrage; VAR I,Entfernung: INTEGER; PROCEDURE RadierStein; BEGIN GotoXY(2*OldSt.X+XX,Hoch+2-OldSt.Y); Write(' '); Write(' '); GotoXY(2*(OldSt.X+Steine[OldA][1].X)+XX,Hoch+2-OldSt.Y-Steine[OldA][1].Y); Write(' '); Write(' '); GotoXY(2*(OldSt.X+Steine[OldA][2].X)+XX,Hoch+2-OldSt.Y-Steine[OldA][2].Y); Write(' '); Write(' '); GotoXY(2*(OldSt.X+Steine[OldA][3].X)+XX,Hoch+2-OldSt.Y-Steine[OldA][3].Y); Write(' '); Write(' '); END; PROCEDURE zeigenext; BEGIN schaff_platz; gotoxy(57,1); write('Nchster Stein:'); GotoXY(2*Stein.X+XX+20,5); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[nextart][1].X)+XX+20,5-Steine[nextart][1].Y); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[nextart][2].X)+XX+20,5-Steine[nextart][2].Y); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[nextart][3].X)+XX+20,5-Steine[nextart][3].Y); Write('['); Write(']'); END; PROCEDURE MaleStein; BEGIN GotoXY(2*Stein.X+XX,Hoch+2-Stein.Y); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[Art][1].X)+XX,Hoch+2-Stein.Y-Steine[Art][1].Y); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[Art][2].X)+XX,Hoch+2-Stein.Y-Steine[Art][2].Y); Write('['); Write(']'); GotoXY(2*(Stein.X+Steine[Art][3].X)+XX,Hoch+2-Stein.Y-Steine[Art][3].Y); Write('['); Write(']'); OldSt:=Stein; OldA:=Art; END; PROCEDURE Turn(A:INTEGER); BEGIN IF NOT ( Feld[Stein.X,Stein.Y] OR Feld[Stein.X+Steine[A][1].X,Stein.Y+Steine[A][1].Y] OR Feld[Stein.X+Steine[A][2].X,Stein.Y+Steine[A][2].Y] OR Feld[Stein.X+Steine[A][3].X,Stein.Y+Steine[A][3].Y] ) THEN begin Art := A; RadierStein; MaleStein; END; END; PROCEDURE Drehe; BEGIN CASE Art OF 2: IF NOT ( Feld[Stein.X,Stein.Y+1] OR Feld[Stein.X+Steine[3][1].X,Stein.Y+1+Steine[3][1].Y] OR Feld[Stein.X+Steine[3][2].X,Stein.Y+1+Steine[3][2].Y] OR Feld[Stein.X+Steine[3][3].X,Stein.Y+1+Steine[3][3].Y] ) THEN begin Art := 3; Stein.Y := Stein.Y+1; RadierStein; MaleStein; END; 3: Turn(2); 4: Turn(8); 5: Turn(9); 6: Turn(10); 7: Turn(15); 8: Turn(4); 9: Turn(5); 10:Turn(12); 11:Turn(7); 12:Turn(14); 13:Turn(11); 14:Turn(6); 15:Turn(13); 16:Turn(19); 17:Turn(16); 18:Turn(17); 19:Turn(18) ELSE END; END; PROCEDURE ErzeugStein; BEGIN art:=nextart; Stein.X:=5; Stein.Y:=Hoch; WHILE ( Feld[Stein.X,Stein.Y] OR Feld[Stein.X+Steine[Art][1].X,Stein.Y+Steine[Art][1].Y] OR Feld[Stein.X+Steine[Art][2].X,Stein.Y+Steine[Art][2].Y] OR Feld[Stein.X+Steine[Art][3].X,Stein.Y+Steine[Art][3].Y] ) AND (Stein.Y > Hoch-3) DO begin Stein.Y := Stein.Y-1; END; IF ( Feld[Stein.X,Stein.Y] OR Feld[Stein.X+Steine[Art][1].X,Stein.Y+Steine[Art][1].Y] OR Feld[Stein.X+Steine[Art][2].X,Stein.Y+Steine[Art][2].Y] OR Feld[Stein.X+Steine[Art][3].X,Stein.Y+Steine[Art][3].Y] ) THEN begin Stop:=TRUE; END; END; PROCEDURE Uebernahme; VAR I:INTEGER; BEGIN Feld[Stein.X,Stein.Y]:=TRUE; IF Hoehe < Stein.Y THEN Hoehe:=Stein.Y; FOR I:=1 TO 3 DO begin Feld[Stein.X+Steine[Art][I].X,Stein.Y+Steine[Art][I].Y]:=TRUE; IF Hoehe < Stein.Y+Steine[Art][I].Y THEN begin Hoehe := Stein.Y+Steine[Art][I].Y; END; END; END; PROCEDURE Runter(From,Amount:INTEGER); VAR I,J:INTEGER; BEGIN FOR I:=From+Amount TO Hoehe DO begin FOR J:=1 TO Breit DO begin Feld[J][I-Amount] := Feld[J][I]; END; END; FOR I:=Hoehe-Amount+1 TO Hoehe DO begin FOR J:=1 TO Breit DO begin Feld[J][I]:=FALSE; END; END; FOR I:=From TO Hoehe DO begin FOR J:=1 TO Breit DO begin IF Feld[J][I] THEN begin GotoXY(2*J+XX,Hoch+2-I); Write('['); Write(']'); end ELSE begin GotoXY(2*J+XX,Hoch+2-I); Write(' '); Write(' '); END; END; END; Lines:=Lines+integer(Amount); IF Lines > FAST THEN begin IF Delay > 400 THEN Delay := Delay - Delay DIV 5; FAST:=FAST+10; END; GotoXY(9,5); Write(Lines:1); Write(CHR(7)); END; PROCEDURE Packen; VAR I,J,Destroy:INTEGER; Leer:BOOLEAN; BEGIN I:=1; WHILE I <= Hoehe DO begin Leer:=TRUE; Destroy:=0; WHILE Leer DO begin FOR J:=1 TO Breit DO begin IF Feld[J][I] THEN begin Leer:=FALSE; END; END; IF Leer THEN begin Destroy:=Destroy+1; IF I FAST THEN begin IF Delay > 400 THEN Delay := Delay - Delay DIV 5; FAST:=FAST+10; END; GotoXY(9,5); Write(Lines:1); Write(CHR(7)); Destroy:=0; END; END; END; I:=I-Destroy; IF Destroy > 0 THEN begin Runter(I,Destroy); Hoehe:=Hoehe-Destroy; END; I:=I+1; END; END; PROCEDURE VolleZeilen; VAR I,J : INTEGER; Voll,Pack: BOOLEAN; BEGIN Pack:=FALSE; FOR I:=1 TO Hoehe DO begin Voll:=TRUE; FOR J:=1 TO Breit DO begin IF NOT Feld[J][I] THEN Voll:=FALSE; END; IF Voll THEN begin Pack:=TRUE; FOR J:=1 TO Breit DO begin Feld[J][I] := FALSE; GotoXY(2*J+XX,Hoch+2-I); Write(' '); Write(' '); END; END; END; IF Pack THEN Packen; END; BEGIN IF KeinStein THEN begin ErzeugStein; MaleStein; KeinStein := FALSE; nextart := INTEGER(system.Random(19)+1); zeigenext; END; D:=0; WHILE D < Delay DO begin get_taste; crt.delay(verzoegerung); (* Diese Warteschleife musste rein *) D:=D + Delay DIV 10; CASE C OF '4': IF NOT ( Feld[Stein.X-1,Stein.Y] OR Feld[Stein.X+Steine[Art][1].X-1,Stein.Y+Steine[Art][1].Y] OR Feld[Stein.X+Steine[Art][2].X-1,Stein.Y+Steine[Art][2].Y] OR Feld[Stein.X+Steine[Art][3].X-1,Stein.Y+Steine[Art][3].Y] ) THEN begin Stein.X := Stein.X-1; RadierStein; MaleStein; END; '5': Drehe; '6': IF NOT ( Feld[Stein.X+1,Stein.Y] OR Feld[Stein.X+Steine[Art][1].X+1,Stein.Y+Steine[Art][1].Y] OR Feld[Stein.X+Steine[Art][2].X+1,Stein.Y+Steine[Art][2].Y] OR Feld[Stein.X+Steine[Art][3].X+1,Stein.Y+Steine[Art][3].Y] ) THEN begin Stein.X := Stein.X+1; RadierStein; MaleStein; END; '2': begin I:=Stein.Y; WHILE Feld[Stein.X][I] = FALSE DO I:=I-1; Entfernung:=Stein.Y-I; I:=Stein.Y+Steine[Art][1].Y; WHILE Feld[Stein.X+Steine[Art][1].X][I] = FALSE DO I:=I-1; IF Stein.Y+Steine[Art][1].Y-I < Entfernung THEN begin Entfernung:=Stein.Y+Steine[Art][1].Y-I; END; I:=Stein.Y+Steine[Art][2].Y; WHILE Feld[Stein.X+Steine[Art][2].X][I] = FALSE DO I:=I-1; IF Stein.Y+Steine[Art][2].Y-I < Entfernung THEN begin Entfernung:=Stein.Y+Steine[Art][2].Y-I; END; I:=Stein.Y+Steine[Art][3].Y; WHILE Feld[Stein.X+Steine[Art][3].X][I] = FALSE DO I:=I-1; IF Stein.Y+Steine[Art][3].Y-I < Entfernung THEN begin Entfernung:=Stein.Y+Steine[Art][3].Y-I; END; Stein.Y:=Stein.Y-Entfernung+1; RadierStein; MaleStein; D:=Delay; end; 'P': WHILE NOT KeyPressed DO; 'Q': Stop:=TRUE ELSE (* Rest ignorieren *) END; (* of CASE *) END; (* of WHILE *) IF NOT ( Feld[Stein.X,Stein.Y-1] OR Feld[Stein.X+Steine[Art][1].X,Stein.Y+Steine[Art][1].Y-1] OR Feld[Stein.X+Steine[Art][2].X,Stein.Y+Steine[Art][2].Y-1] OR Feld[Stein.X+Steine[Art][3].X,Stein.Y+Steine[Art][3].Y-1] ) THEN begin Stein.Y := Stein.Y-1; RadierStein; MaleStein; end ELSE begin Score:=Score + Hoch - integer(Stein.Y); GotoXY(9,7); Write(Score:1); Uebernahme; KeinStein:=TRUE; END; VolleZeilen; END; PROCEDURE Aufruecken(I:INTEGER); VAR K:INTEGER; BEGIN FOR K:=9 downto I DO begin HallofFame[K+1]:=HallofFame[K]; END; END; PROCEDURE Nameneingabe(I:INTEGER); var j : integer; BEGIN for j:=1 to 6 do begin gotoxy(54,i);write(' '); end; GotoXY(60,1); Write('Sie haben eine'); GotoXY(59,2); Write('der zehn hchsten'); GotoXY(58,3); Write('Punktzahlen erreicht!'); GotoXY(60,5); Write('Geben Sie Ihre'); GotoXY(60,6); Write('Initialien ein:'); GotoXY(60,7); Write('---'); GotoXY(60,7); K:=1; REPEAT GotoXY(59+K,7); c:=Readkey; IF ord(c)>31 THEN begin Write(c); HallofFame[I].Name[K]:=c; K:=K+1; IF K>3 THEN begin GotoXY(64,7); Write(' '); c:=Readkey; Write(c); IF c <> CHR(13) THEN begin GotoXY(64,7); Write(' '); K:=3; END; END; end ELSE begin IF (c = CHR(8)) AND (K > 1) THEN begin K:=K-1 end ELSE begin Write(CHR(7)); END; END; UNTIL K>3; END; PROCEDURE HighscoreTable; VAR K:INTEGER; BEGIN for k:=1 to 6 do begin gotoxy(54,k);write(' '); end; GotoXY(60,7); Write('Top Scores & Lines'); GotoXY(60,8); Write(' '); FOR K:=1 TO 10 DO begin GotoXY(60,8+K); Write(HallofFame[K].Name:3); Write(' '); Write(HallofFame[K].Punkte:5); Write(' '); Write(HallofFame[K].Zeilen:1); END; END; PROCEDURE LevelEin; BEGIN GotoXY(1,18); Write('Level (0-9)? '); REPEAT c:=Readkey; Write(c); level:=ord(c)-48; UNTIL (level>=0) and (level<=9); IF Level <> 0 THEN begin GotoXY(1,19); Write('Hhe (0-9) ? '); REPEAT c:=Readkey; Write(c); stapel:=ord(c)-48; UNTIL (stapel>=0) and (stapel<=9); END; END; BEGIN FOR H:=1 TO 10 DO begin HallofFame[H].Punkte:=100; HallofFame[H].Zeilen:=0; HallofFame[H].Name[1]:='-'; HallofFame[H].Name[2]:='-'; HallofFame[H].Name[3]:='-'; END; NewScore:=FALSE; ClrScr; Assign(Filename,'HiScores.Tet'); Reset(Filename); if IOResult=0 then begin ClrScr; Write('Lese Hiscoredaten ein...'); ClrScr; for h:=1 to 10 do begin readln(Filename,HallofFame[h].punkte); readln(Filename,HallofFame[h].zeilen); readln(Filename,HallofFame[h].name); end; close(Filename); end; LevelEin; IF Level <> 0 THEN begin REPEAT Initialisieren; FOR H:=1 TO ORD(Stapel) DO begin FOR K:=1 TO Breit DO begin IF (system.Random(4)=0) OR (system.Random(4)=1) THEN begin Feld[K,H]:=TRUE; GotoXY(2*K+XX,Hoch+2-H); Write('['); Write(']'); END; END; END; Stop:=FALSE; nextart := INTEGER(system.Random(19)+1); REPEAT Abfrage; UNTIL Stop; IF Score > HallofFame[1].Punkte THEN begin schaff_platz; Aufruecken(1); HallofFame[1].Punkte:=Score; HallofFame[1].Zeilen:=Lines; GotoXY(9,8); Write(HallofFame[1].Punkte:1); GotoXY(4,11); Write('Gratulation,'); GotoXY(1,13); Write('Sie haben den HiScore !'); Nameneingabe(1); NewScore:=TRUE; end ELSE begin H:=2; REPEAT IF Score >= HallofFame[H].Punkte THEN begin schaff_platz; Aufruecken(H); HallofFame[H].Punkte:=Score; HallofFame[H].Zeilen:=Lines; Nameneingabe(H); NewScore:=TRUE; H:=10; END; H:=H+1; UNTIL H > 10; END; HighscoreTable; GotoXY(1,17); Write('Game over !'); LevelEin; UNTIL Level = 0; ClrScr; IF NewScore THEN begin Assign(Filename,'HiScores.Tet'); ReWrite(Filename); IF IOResult <> 0 THEN begin ClrScr; Writeln('Fehler beim ffnen (2)! '); c:=Readkey; END; for h:=1 to 10 do begin writeln(Filename,HallofFame[h].punkte); writeln(Filename,HallofFame[h].zeilen); writeln(Filename,HallofFame[h].name); end; IF IOResult <> 0 THEN begin ClrScr; Writeln('Fehler beim Schreiben (2)! '); c:=Readkey; END; Close(Filename); IF IOResult <> 0 THEN begin ClrScr; Writeln('Fehler beim Schlieen (3)! '); c:=Readkey; END; END; (* of IF NewScore *) end; end.