home *** CD-ROM | disk | FTP | other *** search
/ Chip Hitware 10 / Chip_Hitware_Vol_10.iso / chiphit / multmedi / 95licht / install.dll / 1001 / 1 / CRAWLER.DPR < prev    next >
Text File  |  1997-02-02  |  14KB  |  514 lines
  1. {$A+,B-,C-,D+,E-,F-,G+,H-,I-,J+,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
  2. { $MINSTACKSIZE $00004000}
  3. { $MAXSTACKSIZE $00100000}
  4. {$IMAGEBASE $02000000}
  5. {$APPTYPE GUI}
  6.  
  7. library Crawler;
  8.  
  9. { Important note about DLL memory management: ShareMem must be the
  10.   first unit in your library's USES clause AND your project's (select
  11.   View-Project Source) USES clause if your DLL exports any procedures or
  12.   functions that pass strings as parameters or function results. This
  13.   applies to all strings passed to and from your DLL--even those that
  14.   are nested in records and classes. ShareMem is the interface unit to
  15.   the DELPHIMM.DLL shared memory manager, which must be deployed along
  16.   with your DLL. To avoid using DELPHIMM.DLL, pass string information
  17.   using PChar or ShortString parameters. }
  18.  
  19. uses
  20. {  SysUtils,
  21.   Classes;}
  22.   WinTypes,
  23.   Messages,
  24. {  SysUtils,}
  25.   LGDAPI,
  26.   LGDUTI
  27. {$ifdef USESOUNDS}
  28.      , iSounds
  29. {$endif}
  30.   ;
  31.  
  32. {$ifdef ENGLISH}
  33. {$r se_crawl.res}
  34. {$else}
  35. {$r ss_crawl.res}
  36. {$endif}
  37.  
  38. const HELPFILE = 'LGD95.HLP';
  39.       HELPKEY:array[0..31]of char = 'Crawler';
  40.     
  41. const AppName = 'LGD_Crawler';
  42.  
  43. var
  44.     cxClient, cyClient: integer;
  45.     fPalette: boolean;
  46.  
  47. const MAXTAIL = 100;
  48.       MAXWORM = 50;
  49.       __MAXTAIL:integer = 20;
  50.       __MAXWORM:integer = 20;
  51.       __TURBO: integer = 0;
  52.  
  53. type
  54.      TPosition = record
  55.        x, y: integer;
  56.      end;
  57.       
  58.      TailType = record
  59.        head, tail: integer;
  60.        TailPos: array [1..MAXTAIL] of TPosition;
  61.      end;
  62.  
  63.      CrawlerType = record
  64.        xPos, yPos: integer;
  65.        Dir: integer;
  66.        l, m, d: TColorRef;
  67.        Tail: TailType;
  68.      end;
  69.  
  70. var Crawlers: array [1..MAXWORM] of CrawlerType;
  71. {$ifdef USESOUNDS}
  72.   cSoundTime:integer;
  73. {$endif}
  74.  
  75. Procedure MoveTo (dc: hdc; xPos, yPos: integer);
  76. begin
  77.   MoveToEx (dc, xPos, yPos, NIL);
  78. end;
  79.  
  80.  
  81. Procedure DrawSegment (dc:hdc; xPos, yPos: integer; l,m,d: TColorRef);
  82. var x, y: integer;
  83.     lb:TLogBrush;
  84.     Brush: hBrush;
  85.     Pen: hPen;
  86. begin
  87.   dec (xPos, 3);  { adresse des mittelpunkts ⁿbergeben }
  88.   dec (yPos, 3);  { received address of center }
  89.  
  90.   lb.lbStyle := bs_Solid;
  91.   lb.lbColor := m;
  92.   lb.lbHatch := 0;
  93.   Brush := CreateBrushIndirect (lb);
  94.  
  95.   Brush := SelectObject (dc, Brush);
  96.   Pen := SelectObject (dc, GetStockObject (NULL_PEN));
  97.   Rectangle (dc, xPos + 2, yPos + 2, xPos + 8, yPos + 8);
  98.   DeleteObject (SelectObject (dc, Brush));
  99.   Pen := SelectObject (dc, CreatePen (ps_Solid, 1, l));
  100.   MoveTo (dc, xPos + 1, yPos + 6);
  101.   LineTo (dc, xPos + 1, yPos + 1);
  102.   LineTo (dc, xPos + 8, yPos + 1);
  103.   MoveTo (dc, xPos, yPos + 2);
  104.   LineTo (dc, xPos, yPos + 7);
  105.   MoveTo (dc, xPos + 2, yPos);
  106.   LineTo (dc, xPos + 7, yPos);
  107.   DeleteObject (SelectObject (dc, Pen));
  108.   Pen := SelectObject (dc, CreatePen (ps_Solid, 1, d));
  109.   MoveTo (dc, xPos + 1, yPos + 7);
  110.   LineTo (dc, xPos + 7, yPos + 7);
  111.   LineTo (dc, xPos + 7, yPos + 1);
  112.   MoveTo (dc, xPos + 2, yPos + 8);
  113.   LineTo (dc, xPos + 7, yPos + 8);
  114.   MoveTo (dc, xPos + 8, yPos + 2);
  115.   LineTo (dc, xPos + 8, yPos + 7);
  116.   DeleteObject (SelectObject (dc, Pen));
  117. end;
  118.  
  119. Procedure InitCrawlers;
  120. var i, j: integer;
  121. begin
  122.   for j := 1 to __MAXWORM do
  123.     with Crawlers [j] do
  124.       begin
  125.     for i := 1 to __MAXTAIL do
  126.       begin
  127.         Tail.TailPos [i].x := -17;
  128.         Tail.TailPos [i].y := -17;
  129.       end;
  130.     xPos := random (cxClient);
  131.     yPos := random (cyClient);
  132.     dir  := random (16 * 4);
  133.     Tail.tail := 1;
  134.     Tail.head := __MAXTAIL;
  135.     if fPalette {(pif <> nil)} then
  136.       begin
  137.         i := random (7);
  138.         l := PaletteIndex (ColorIndexesColorScales [i * 8 + 7]);
  139.         m := PaletteIndex (ColorIndexesColorScales [i * 8 + 5]);
  140.         d := PaletteIndex (ColorIndexesColorScales [i * 8 + 3]);
  141.       end
  142.     else
  143.       begin
  144.         i := random (7);
  145.         case i of
  146.           0: begin
  147.            l := RGB (255, 255, 255); { grau / grey}
  148.            m := RGB (192, 192, 192);
  149.            d := RGB (128, 128, 128);
  150.          end;
  151.           1: begin
  152.            l := RGB (255, 255, 0); { gelb / yellow }
  153.            m := RGB (192, 192, 0);
  154.            d := RGB (128, 128, 0);
  155.          end;
  156.           2: begin
  157.            l := RGB (0, 255, 255); { cyan }
  158.            m := RGB (0, 192, 192);
  159.            d := RGB (0, 128, 128);
  160.          end;
  161.           3: begin
  162.            l := RGB (0, 0, 255);   { blau / blue }
  163.            m := RGB (0, 0, 192);
  164.            d := RGB (0, 0, 128);
  165.          end;
  166.           4: begin
  167.            l := RGB (255, 0, 0);   { rot / red}
  168.            m := RGB (192, 0, 0);
  169.            d := RGB (128, 0, 0);
  170.          end;
  171.           5: begin
  172.            l := RGB (255, 0, 255);   { magenta }
  173.            m := RGB (192, 0, 192);
  174.            d := RGB (128, 0, 128);
  175.          end;
  176.           6: begin
  177.            l := RGB (0, 255, 0);   { grⁿn / green }
  178.            m := RGB (0, 192, 0);
  179.            d := RGB (0, 128, 0);
  180.          end;
  181.         end;                           { german and english share the same roots ... }
  182.       end;
  183.       end;
  184. end;
  185.  
  186. Procedure MoveCrawlers (dc: hDC);
  187. var i,j:integer;
  188. begin
  189.   for i := 1 to __MAXWORM do
  190.     with Crawlers [i] do
  191.       begin
  192.     DrawSegment (dc, Tail.TailPos [Tail.Tail].x, Tail.TailPos [Tail.Tail].y, 0, 0, 0);
  193.     DrawSegment (dc, xPos, yPos, l, m, d);
  194.     Tail.TailPos [Tail.Head].x := xPos;
  195.     Tail.TailPos [Tail.Head].y := yPos;
  196.     inc (Tail.Head);
  197.     if Tail.Head > __MAXTAIL then
  198.       Tail.Head := 1;
  199.     inc (Tail.Tail);
  200.     if Tail.Tail > __MAXTAIL then
  201.       Tail.Tail := 1;
  202.     case Dir div 4 of
  203.       0: begin inc (xPos, 6); end;
  204.       1: begin inc (xPos, 4); inc (yPos, 2); end;
  205.       2: begin inc (xPos, 3); inc (yPos, 3); end;
  206.       3: begin inc (xPos, 2); inc (yPos, 4); end;
  207.       4: begin                inc (yPos, 6); end;
  208.       5: begin dec (xPos, 2); inc (yPos, 4); end;
  209.       6: begin dec (xPos, 3); inc (yPos, 3); end;
  210.       7: begin dec (xPos, 4); inc (yPos, 2); end;
  211.       8: begin dec (xPos, 6); end;
  212.       9: begin dec (xPos, 4); dec (yPos, 2); end;
  213.      10: begin dec (xPos, 3); dec (yPos, 3); end;
  214.      11: begin dec (xPos, 2); dec (yPos, 4); end;
  215.      12: begin                dec (yPos, 6); end;
  216.      13: begin inc (xPos, 2); dec (yPos, 4); end;
  217.      14: begin inc (xPos, 3); dec (yPos, 3); end;
  218.      15: begin inc (xPos, 4); dec (yPos, 2); end;
  219.     end;
  220.     j := integer (random (5)) - 2;
  221.     dir := dir + j;
  222.     if xPos >= cxClient then
  223.       begin
  224.         xPos := cxClient-1;
  225.         dir := 8 * 4;
  226.       end;
  227.     if xPos < 0 then
  228.       begin
  229.         xPos := 0;
  230.         dir := 0;
  231.       end;
  232.     if yPos >= cyClient then
  233.       begin
  234.         yPos := cyClient -1;
  235.         dir := 12 * 4;
  236.       end;
  237.     if yPos < 0 then
  238.       begin
  239.         yPos := 0;
  240.         dir := 4 * 4;
  241.       end;
  242.     dir := dir and 63;
  243.       end;
  244. end;
  245.  
  246. Procedure ReadProfile (var mdModuleData: TModuleData);
  247. var p: Pointer;
  248.     i: integer;
  249. begin
  250.   with mdModuleData.pms^ do
  251.     begin
  252.       LgdRegOpenKey (p, sCallerName, sSaverName);
  253.       LgdRegGetInteger (p, appname, 'Worms', '10', __MAXWORM);
  254.       LgdRegGetInteger (p, appname, 'Length', '10', __MAXTAIL);
  255.       LgdRegGetInteger (p, appname, 'Delay', '20', __TURBO);
  256.       LgdRegCloseKey (p);
  257.     end;
  258. (*
  259.   __MAXWORM := GetPrivateProfileInt (appname, 'Anzahl', 10, Ini);
  260.   __MAXTAIL := GetPrivateProfileInt (appname, 'LΣnge', 10, Ini);
  261.   __TURBO := GetPrivateProfileInt (appname, 'lDelay', 20, Ini);
  262. *)
  263. end;
  264.  
  265. Procedure WriteProfile (var mdModuleData: TModuleData);
  266. var p: Pointer;
  267.     s:string;
  268. begin
  269.   with mdModuleData.pms^ do
  270.     begin
  271.       LgdRegOpenKey (p, sCallerName, sSaverName);
  272.       LgdRegSetInteger (p, appname, 'Worms', __MAXWORM);
  273.       LgdRegSetInteger (p, appname, 'Length', __MAXTAIL);
  274.       LgdRegSetInteger (p, appname, 'Delay', __TURBO);
  275.       LgdRegCloseKey (p);
  276.     end;
  277. (*
  278.   str (__MAXWORM, s);
  279.   s := s + #0;
  280.   WritePrivateProfileString (AppName, 'Anzahl', @s[1], Ini);
  281.   str (__MAXTAIL, s);
  282.   s := s + #0;
  283.   WritePrivateProfileString (AppName, 'LΣnge', @s[1], Ini);
  284.   str (__TURBO, s);
  285.   s := s + #0;
  286.   WritePrivateProfileString (AppName, 'lDelay', @s[1], Ini);
  287. *)
  288. end;
  289.  
  290. function Options(Dialog: HWnd; Message, WParam: Word;
  291.   LParam: Longint): Bool; stdcall; export;
  292. var trans: bool;
  293. begin
  294.   Options := True;
  295.   case Message of
  296.     wm_InitDialog:
  297.       begin
  298. {       fLocalHelp := FALSE;}
  299.     SetDlgItemInt (Dialog, 103, __MAXWORM, FALSE);
  300.     SetDlgItemInt (Dialog, 104, __MAXTAIL, FALSE);
  301.     SetDlgItemInt (Dialog, 105, __TURBO, FALSE);
  302. {$ifdef USESOUNDS}
  303.     if THSndVersion > 0 then
  304.       ShowWindow (GetDlgItem (dialog, 199), sw_normal);
  305. {$endif}
  306.     Exit;
  307.       end;
  308.     wm_Command:
  309.       if (WParam = 1) or (WParam = id_Cancel) then
  310.     begin
  311.       if (wParam = 1) then
  312.         begin
  313.           { *** Note: I changed the prototype for GetDlgItemInt in
  314.         Windows.Pas to make it compatible with Delphi 1.0 / BP 7.
  315.         Remove the address operator @ if you don't want to change 
  316.         Windows.Pas. The old style was more logical ... }
  317.           __MAXWORM := GetDlgItemInt (Dialog, 103, @trans, FALSE);
  318.           __MAXTAIL := GetDlgItemInt (Dialog, 104, @trans, FALSE);
  319.           __TURBO   := GetDlgItemInt (Dialog, 105, @trans, FALSE);
  320.           if __MAXTAIL < 2 then
  321.         __MAXTAIL := 2
  322.           else if __MAXTAIL > MAXTAIL then
  323.         __MAXTAIL := MAXTAIL;
  324.           if __MAXWORM < 1 then
  325.         __MAXWORM := 1
  326.           else if __MAXWORM > MAXWORM then
  327.         __MAXWORM := MAXWORM;
  328.           if __TURBO < 0 then
  329.         __TURBO := 0
  330.           else if __TURBO > 9999 then
  331.         __TURBO := 9999;
  332.         end;
  333. {         if fLocalHelp then
  334.         WinHelp (Dialog, HelpFile, help_Quit, 0);}
  335.       EndDialog(Dialog, ord (wParam = id_OK));
  336.       Exit;
  337.     end
  338.       else if (wParam = 102) or (wParam = ID_HELPKEY_F1) then
  339.     begin
  340.       WinHelp (GetParent (dialog), HELPFILE, HELP_KEY, LongInt (@HELPKEY));
  341. {         WinHelp (dialog, HELPFILE, help_Key, LONGINT (@HELPTEXT));
  342.       fLocalHelp := TRUE;}
  343.       exit;
  344.     end
  345. {$ifdef USESOUNDS}
  346.       else if (wParam = 199) then
  347.     begin
  348.       THSndOptions (AppName, dialog);
  349.     end
  350. {$endif}
  351.     ;
  352.   end;
  353.   Options := False;
  354. end;
  355.  
  356.  
  357.  
  358.        { requests information about screen saver }
  359. Function ScrInfo (var lisInfo: TLgdInfoStruct): bool; stdcall; export;
  360. begin
  361.   ScrInfo := FALSE;
  362.   with lisInfo do
  363.     begin
  364.       if cBytes < sizeof (lisInfo) then
  365.     exit;
  366.       if cMagic <> lMagic then
  367.     exit;
  368.       afSaverFlags := {SCR_LEAVESBLANK + SCR_MUSTHAVENONBLANK +}
  369.          {SCR_CONFIGDIALOG +} SCR_HELPAVAILABLE;
  370. {$ifdef ENGLISH}
  371.       StrCopy (@strTitle[1], 'CCrawler');
  372.       StrCopy (@strInfo[1], 'Crawler Screen Saver'#10#10+
  373.          'Sample of a simple screen saver module for'#10+
  374.          '95 Lights Go Down'#10#10+
  375.          'Delphi Source Code included!');
  376. {$else}
  377.       StrCopy (@strTitle[1], 'CCrawler');
  378.       StrCopy (@strInfo[1], 'Crawler Bildschirmschoner'#10#10+
  379.          'Beispiel eines einfachen Bildschirmschoners fⁿr '#10+
  380.          '95 Lichter gehen aus'#10#10#+
  381.          'Der Delphi Quelltext liegt bei!');
  382. {$endif}
  383.       StrCopy (@strHelpFile[1], HELPFILE);
  384.       StrCopy (@strHelpKey[1], HELPKEY);
  385.     end;
  386.   ScrInfo := TRUE;
  387. end;
  388.  
  389.        { display information about screen saver }
  390. Function ScrAbout (hwndParent: HWND): bool; stdcall; export;
  391. begin
  392.   ScrAbout := TRUE;
  393.   LgdAboutBox (hwndParent, 0,
  394.                'Crawler',
  395.                '⌐ 1992-97 Thomas H÷vel Software'#10+
  396.                'Saturnstr. 45, 53842 Troisdorf, Germany'#10+
  397.                'All Rights reserved!',
  398.   {$ifdef SHARE}
  399.                FALSE,
  400.   {$else}
  401.                TRUE,
  402.   {$endif}
  403.                3);
  404. {  MessageBox (hwndParent, 'Hello, World!', 'About', mb_ok);}
  405. end;
  406.  
  407.        { these functions are called to execute the screen saver }
  408.        { init screen saver - should save pointer to structure }
  409. Function ScrInit (var mdModuleData: TModuleData): bool; stdcall; export;
  410. begin
  411.   with mdModuleData.pms^ do
  412.     begin
  413.       ReadProfile (mdModuleData);
  414.       fSupportsIdleFunction := TRUE;
  415.       lTimerDelay := 1000; { max. speed }
  416.       lCallDelay := __TURBO;
  417.       cxClient := cxScreen;
  418.       cyClient := cyScreen;
  419.       fPalette := pss^.iBPP >= 8;
  420.     end;
  421. {$ifdef USESOUNDS}
  422.   cSoundTime := 5 + random (5);
  423. {$endif}
  424.   ScrInit := TRUE;
  425.   Randomize;
  426.   InitCrawlers;
  427. end;
  428.  
  429. Procedure ScrDone (var mdModuleData: TModuleData); stdcall; export;
  430. begin
  431. end;
  432.  
  433. Procedure ScrIdle (var mdModuleData: TModuleData); stdcall; export;
  434.    { called at maximum rate if requested by saver }
  435. var dc: hdc;
  436.     x, y: integer;
  437.     hpalOld: HPalette;
  438. begin
  439.   with mdModuleData.pms^ do
  440.     begin
  441.       dc := GetDC (hwndSaver);
  442.       if pss^.iBPP >= 8 then
  443.     begin
  444.       hpalOld := SelectPalette (dc, pss^.hpalModule, FALSE);
  445.       RealizePalette (dc);
  446.     end;
  447.       MoveCrawlers (dc);
  448.       if pss^.iBPP >= 8 then
  449.     begin
  450.       SelectPalette (dc, hpalOld, FALSE);
  451.     end;
  452.       ReleaseDC (hwndSaver, dc);
  453.     end;
  454. end;
  455.  
  456. Procedure ScrTimer (var mdModuleData: TModuleData); stdcall; export;
  457.    { called by timer with selected interval }
  458. var dc: hdc;
  459.     x, y: integer;
  460. begin
  461. {$ifdef USESOUNDS}
  462.   with mdModuleData.pms^ do
  463.     begin
  464.       dec (cSoundTime);
  465.       if cSoundTime < 0 then
  466.     begin
  467.       THSndRandom (AppName, FALSE);
  468.       cSoundTime := 10 + random (10);
  469.     end;
  470.     end;
  471. {$endif}
  472. (*
  473.   with mdModuleData.pms^ do
  474.     begin
  475.       dc := GetDC (hwndSaver);
  476.       x := random (cxScreen);
  477.       y := random (cyScreen);
  478.       SetPixel (dc, x-1, y, RGB (192, 192, 192));
  479.       SetPixel (dc, x+1, y, RGB (192, 192, 192));
  480.       SetPixel (dc, x, y-1, RGB (192, 192, 192));
  481.       SetPixel (dc, x, y+1, RGB (192, 192, 192));
  482.       SetPixel (dc, x, y, RGB (255, 255, 255));
  483.       ReleaseDC (hwndSaver, dc);
  484.     end;
  485. *)
  486. end;
  487.  
  488.    {  display configuration dialog }
  489. Function ScrConfig (var mdModuleData: TModuleData; hwndParent: HWND): integer; stdcall; export;
  490. var Proc: TFarProc;
  491.     i: integer;
  492. begin
  493.   ReadProfile (mdModuleData);
  494.   Proc := MakeProcInstance(@Options, HInstance);
  495.   i := DialogBox(HInstance, 'OPTIONBOX', hwndParent, Proc);
  496.   FreeProcInstance(Proc);
  497.  
  498.   if i > 0 then
  499.     WriteProfile (mdModuleData);
  500.   ScrConfig := i;
  501. end;
  502.  
  503. exports
  504.   ScrInfo index 11,
  505.   ScrAbout index 12,
  506.   ScrInit index 13,
  507.   ScrDone index 14,
  508.   ScrIdle index 15,
  509.   ScrTimer index 16,
  510.   ScrConfig index 17;
  511.  
  512. begin { library }
  513. end.
  514.