home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / PROG_PAS / TVTOYS.ZIP / RESTEST.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-03  |  18KB  |  528 lines
  1. (***************************************************************************
  2.   ResTest program
  3.   Official playground, odd bits and pieces, resources, config files etc
  4.   PJB October 8, 1993, CompuServe mail to INTERNET:d91-pbr@nada.kth.se
  5.   Copyright 1993, All Rights Reserved
  6.   Free source, use at your own risk.
  7.   If modified, please state so if you pass this around.
  8.  
  9.   Demonstrates video config files, resource fonts and video tests
  10.   configurability. This program doesn't look for VESA and V7 without
  11.   being told to do so, it saves the desktop video state and it gives
  12.   transparent user access to resource fonts. There is also a self
  13.   modifying menu.
  14.  
  15.   StoreCfg is currently used before ResDemoApp.Done so that no config
  16.   file is saved if the program aborts during initialization. This
  17.   was intended to prevent unnecessary elimination of video checks,
  18.   whether that is any good I don't know.
  19.  
  20.   Another approach is to save a config file before testing that says
  21.   no testing should be done, and another after the testing with full
  22.   testing enabled. This doesn't leave anything to the user, but the
  23.   program might crash the first time, if the video BIOS is picky.
  24.  
  25.     if not ConfigOK then    { No config file }
  26.     begin
  27.       StoreCfg;             { VideoTypesToCheck is [] }
  28.       VideoTypesToCheck:=[vtVesa,vtVideo7];
  29.     end;
  30.  
  31.     inherited Init;
  32.  
  33.     if not ConfigOK then    { No config file }
  34.       StoreCfg;             { VideoTypesToCheck is [vtVesa,vtVideo7] }
  35.  
  36.  
  37.   Be careful about using TV's message box in StoreCfg, though, there
  38.   might not be any application:
  39.  
  40.     if (S.Status<>stOK) and (Application<>Nil) then
  41.       MessageBox(...)
  42.  
  43.  
  44. ***************************************************************************)
  45. program ResTest;
  46.  
  47. {$I toyCfg}
  48.  
  49. {$B-,X+}
  50.  
  51. {$IFNDEF ResFonts}
  52.   Psst! Define ResFonts in TOYCFG.PAS, or this demo is gets boring!
  53. {$ENDIF}
  54.  
  55.   uses
  56.     App, Dialogs, Drivers, Menus, MsgBox, Objects, Views,
  57.     toyPrefs, {$I hcFile}       (* Help contexts etc *)
  58.     ColorBox, ColorSel,         (* Color selection dialog *)
  59.     TVPal, Pal,                 (* Palette changing dialog *)
  60.     FontDlg, FontFiles,         (* Fonts *)
  61.     HelpFile,                   (* Help *)
  62.     ModeDlg,                    (* Video mode selection dialog *)
  63.     StrmRec,                    (* Stream registration (RegisterFontFile) *)
  64.     toyApp, toyUtils,
  65.     TVVideo,                    (* TV specific video support *)
  66.     TVUtils,
  67.     Vesa,                       (* Vesa; is Vesa scanning possible? *)
  68.     Video;                      (* Video mode searching and setting *)
  69.  
  70.   type
  71.     TResDemoApp =
  72.       object (TToyApp)
  73.         ResFile   : TResourceFile;
  74.         LinesMenu : PMenu;
  75.         constructor Init;
  76.         procedure CalcLinesMenu;
  77.         procedure CreateResourceFile;
  78.         procedure HandleEvent(var Event:TEvent); virtual;
  79.         procedure InitMenubar; virtual;
  80.         procedure InitStatusLine; virtual;
  81.         procedure StoreCfg;
  82.         procedure VideoTestsDialog(VT:SpecialVideoTypes);
  83.       end;
  84.  
  85.  
  86.   (*******************************************************************
  87.     Demo commands
  88.   *******************************************************************)
  89.   const
  90.     toyStart     = 100;
  91.     cm8p         = toyStart+0;
  92.     cm14p        = toyStart+1;
  93.     cm16p        = toyStart+2;
  94.     cmVideoMode  = toyStart+3;
  95.     cmVideoInfo  = toyStart+4;
  96.     cmSelectFont = toyStart+5;
  97.     cmVideoTests = toyStart+6;
  98.     cm12p        = toyStart+7;
  99.     cmColor      = toyStart+8;
  100.     cmPalette    = toyStart+9;
  101.  
  102.   const
  103.     CfgName      = 'RESTEST.CFG';
  104.     ResName      = 'RESTEST.REZ';
  105.  
  106.  
  107. (***************************************************************************
  108.   Things that belong in a unit
  109. ***************************************************************************)
  110.  
  111.   (*******************************************************************
  112.     Restore a video state from stream
  113.   *******************************************************************)
  114.   procedure LoadVideoState(var S:TStream; App:PToyApp);
  115.     var
  116.       W : Word;
  117.       TVVideoState : VideoState;
  118.   begin
  119.     LoadVideoModes(S);
  120.  
  121.     S.Read(TVVideoState, SizeOf(TVVideoState));
  122.     S.Read(LastFontNameLoaded, SizeOf(LastFontNameLoaded));
  123.     App^.LoadPalette(S);
  124.     VideoPalette.Load(S);
  125.     S.Read(LastFontTypeUsed, SizeOf(LastFontTypeUsed));
  126.  
  127.     if S.Status=stOK then
  128.       TVVideoState.Restore;
  129.   end;
  130.  
  131.  
  132.   (*******************************************************************
  133.     Store current video state on a stream
  134.   *******************************************************************)
  135.   procedure StoreVideoState(var S:TStream);
  136.     var
  137.       TVVideoState : VideoState;
  138.   begin
  139.     StoreVideoModes(S);
  140.  
  141.     TVVideoState.Save;
  142.     S.Write(TVVideoState, SizeOf(TVVideoState));
  143.     S.Write(LastFontNameLoaded, SizeOf(LastFontNameLoaded));
  144.     PToyApp(Application)^.StorePalette(S);
  145.     VideoPalette.Store(S);
  146.     S.Write(LastFontTypeUsed, SizeOf(LastFontTypeUsed));
  147.   end;
  148.  
  149.  
  150. (***************************************************************************
  151.   The application
  152. ***************************************************************************)
  153.  
  154.   (*******************************************************************
  155.     Init app, load a config file with video info if there (this is
  156.     what messes it up), create resource file if necessary
  157.     This code includes TToyApp's Init, so we call TApplication.Init
  158.     directly.
  159.     Ideally we don't call TApplication.Init at all, but rather init
  160.     the app first (without calling InitVideo) and then decide what
  161.     kind of video initalizing we want...
  162.   *******************************************************************)
  163.   constructor TResDemoApp.Init;
  164.     var
  165.       S         : TDosStream;
  166.       ConfigOK  : Boolean;
  167.       InitState : VideoState;
  168.   begin
  169.     RegisterObjects;
  170.     RegisterFontFile;
  171.     RegisterHelpFile;
  172.  
  173.     (*******************************************************************
  174.       Open and read config file if there is one
  175.     *******************************************************************)
  176.     { Do we have a config file? }
  177.     S.Init(ExeDir+CfgName, stOpenRead);
  178.     { This zeros VideoTypesToCheck if no cfg file, so checks only EVGA }
  179.     S.Read(VideoTypesToCheck, SizeOf(VideoTypesToCheck));
  180.  
  181.     CheckVideoType;             (* Determine video type *)
  182.     InitState.Save;             (* Use temporary variable... *)
  183.  
  184.     VideoPalette.Init;          (* Initialize palette *)
  185.  
  186.     LoadVideoState(S, @Self);   (* Load previously saved video state *)
  187.     S.Done;
  188.     ConfigOK:=S.Status=stOK;
  189.  
  190.     (*******************************************************************
  191.       Init app, TToyApp replacement code
  192.     *******************************************************************)
  193.     if ConfigOK then
  194.     begin
  195.       PreventModeSwitch;        (* We loaded a new video mode *)
  196.       if VideoType<>Other then
  197.         ReloadPalette;
  198.     end;
  199.  
  200.     TApplication.Init;          (* We don't want to call TToyApp.Init *)
  201.     DosVideoState:=InitState;   (* Save startup video mode *)
  202.  
  203.     (* Get ScreenMode (if there is no cfg file) *)
  204.     ScreenMode:=GetSpecialVideoMode;
  205.  
  206.     (*******************************************************************
  207.       Introductory text
  208.     *******************************************************************)
  209.     HelpFileName:='HELPTEST.HLP';
  210.     ShowHelp(hcRezIntro);
  211.  
  212.     (*******************************************************************
  213.       Is there a resource file?  No? Create it!
  214.     *******************************************************************)
  215.     S.Init(ExeDir+ResName, stOpenRead);
  216.     S.Done;
  217.     if S.Status<>stOK then
  218.       CreateResourceFile;        { No, create it }
  219.  
  220.     (*******************************************************************
  221.       Open the resource file
  222.     *******************************************************************)
  223.     ResFile.Init(New(PBufStream, Init(ExeDir+ResName, stOpenRead, 1024)));
  224.  
  225.     if ResFile.Stream^.Status<>stOK then      (* OOPS! *)
  226.     begin
  227.       MessageBox(^C'Resource file not readable', Nil, mfError+mfOKButton);
  228.       Done;
  229.       Halt;
  230.     end;
  231.  
  232.     (*******************************************************************
  233.       Reload last font, might need resource file
  234.     *******************************************************************)
  235.     LastFontResourceFile:=@ResFile;
  236.     if VideoType<>Other then
  237.       VideoModeChanged:=ReloadFontAndPalette;    (* This is important! *)
  238.     VideoModeChanged;
  239.  
  240.     (*******************************************************************
  241.       Disable some features on non VGA cards
  242.     *******************************************************************)
  243.     if VideoType=Other then
  244.       DisableCommands([cmVideoMode, cmSelectFont, cm8p, cm12p, cm14p, cm16p]);
  245.     if VideoType=EGA then
  246.       DisableCommands([cm16p]);
  247.  
  248.     if VideoType=Other then
  249.       MessageBox('This program intended for EGA/VGA', Nil, mfInformation+mfOKButton);
  250.  
  251.     (*******************************************************************
  252.       No config file, ask user for action
  253.     *******************************************************************)
  254.     if not ConfigOK then
  255.       VideoTestsDialog([vtVesa,vtVideo7]);
  256.   end;
  257.  
  258.  
  259.   (*******************************************************************
  260.     Create a Video menu with whatever lines settings available.
  261.     Notice that menus are created bottom-to-top.
  262.     It's impossible to make accurate predictions about the number
  263.     of lines after a font change, the hardware might change the
  264.     number of scanlines...
  265.   *******************************************************************)
  266.   procedure TResDemoApp.CalcLinesMenu;
  267.     var
  268.       P         : PMenuItem;
  269.  
  270.     (* Add "## lines" to menu list *)
  271.     procedure Add(Points:Integer; Command, HelpCtx:Word);
  272.       function Check:String;
  273.       begin
  274.         if Points=Mem[Seg0040:CrtPoints] then
  275.           Check:='√ '
  276.         else
  277.           Check:='  ';
  278.       end;
  279.     begin
  280.       P:=NewItem(Check+ToStr(VideoScanLines div Points)+' lines', '',
  281.                  kbNoKey, Command, HelpCtx, P);
  282.     end;
  283.  
  284.   begin
  285.     DisposeMenuItems(LinesMenu^.Items);
  286.  
  287.     P:=
  288.       NewLine(
  289.       NewItem('Select ~f~ont...', '', kbNoKey, cmSelectFont, hctoyVSelectFont,
  290.       NewLine(
  291.       NewItem('Select video ~m~ode...', '', kbNoKey, cmVideoMode, hctoyVVideoMode,
  292.       Nil))));
  293.  
  294.     Add(8,  cm8p,  hctoyV8p);
  295.     Add(12, cm12p, hcNoContext);
  296.     Add(14, cm14p, hctoyV14p);
  297.     if VideoType=VGA then
  298.       Add(16, cm16p, hctoyV16p);
  299.  
  300.     LinesMenu^.Items:=P;
  301.     LinesMenu^.Default:=P;
  302.   end;
  303.  
  304.  
  305.   (*******************************************************************
  306.     There was an error writing the resource
  307.   *******************************************************************)
  308.   procedure ErrorInStream; far;
  309.   begin
  310.     MessageBox(^C'Failed to create resource file', Nil, mfError+mfOKButton);
  311.     Application^.Done;
  312.     Halt;
  313.   end;
  314.  
  315.  
  316.   (*******************************************************************
  317.     Create a resource file with one font and the corresponding
  318.     list of font resource keys
  319.   *******************************************************************)
  320.   procedure TResDemoApp.CreateResourceFile;
  321.     var
  322.       C : TStringCollection;
  323.     procedure AddFont(Name:String);
  324.       var
  325.         Font : TFontFile;
  326.     begin
  327.       C.Insert(NewStr(Name));            (* Save the resource key *)
  328.       Font.Init;
  329.       if Font.DoRead(Name+'.COM') then
  330.       begin
  331.         Font.Desc:=Name+', this is a font resource!';
  332.         ResFile.Put(@Font, Name)
  333.       end
  334.       else
  335.       begin
  336.         MessageBox(^C'Failed to read font '+Name, Nil, mfError+mfOKButton);
  337.         ResFile.Stream^.Error(stWriteError, 0);
  338.       end;
  339.     end;
  340.   begin
  341.     Notice('', ^M^M^C'Creating resource file...');
  342.  
  343.     StreamError:=@ErrorInStream;
  344.     ResFile.Init(New(PBufStream, Init(ExeDir+ResName, stCreate, 1024)));
  345.  
  346.     C.Init(10,10);
  347.  
  348.     AddFont('CHIC12');
  349.  
  350.     ResFile.Put(@C, toyFontListKey);    (* FontDlg needs this *)
  351.     ResFile.Done;
  352.     StreamError:=Nil;
  353.  
  354.     NoNotice;
  355.     MessageBox(^C'Resource file created.', Nil, mfInformation+mfOKButton);
  356.   end;
  357.  
  358.  
  359.   (*******************************************************************
  360.     Commands
  361.   *******************************************************************)
  362.   procedure TResDemoApp.HandleEvent;
  363.  
  364.     (*******************************************************************
  365.       This is the Color selection dialog
  366.     *******************************************************************)
  367.     procedure Colors;
  368.       var
  369.         D : PColorBox;
  370.     begin
  371.       D:=New(PColorBox, Init(
  372.         ColorGroup('Desktop',
  373.           DeskTopColorItems(nil),
  374.         ColorGroup('Menus',
  375.           MenuColorItems(nil),
  376.         ColorGroup('Dialogs',
  377.           DialogColorItems(dpGrayDialog, nil),
  378.         HelpColorItems(
  379.         nil))))));
  380.  
  381.       ExecuteDialog(D, GetPalette);
  382.     end;
  383.  
  384.     const
  385.       InternalArr : array [cm8p..cm16p] of Byte =
  386.         (Internal8x8Font, Internal8x14Font, Internal8x16Font);
  387.   begin
  388.     inherited HandleEvent(Event);
  389.  
  390.     if Event.What=evCommand then
  391.     begin
  392.       case Event.Command of
  393.         cm8p..cm16p:   TVVideo.SetInternalFont(InternalArr[Event.Command]);
  394.         cm12p:         LoadResFont(@ResFile, 'CHIC12');
  395.  
  396.         cmColor:       Colors;
  397.  
  398.         cmPalette:
  399.           ExecuteDialog(New(PVideoPaletteDialog, Init(0)), @VideoPaletteData);
  400.  
  401.         cmSelectFont:  SelectFontDialog(ExeDir, @ResFile);
  402.         cmVideoMode:
  403.           if not HasToScan or               (* Already scanned *)
  404.              VesaScanningPossible or        (* VESA handles it *)
  405.              (MessageBox(^C'Have to do some tests. There is'+
  406.                          ^M^C'no guarantee that it works...', Nil,
  407.                          mfWarning+mfOkCancel)=cmOK) then
  408.           begin
  409.             SetUpVideoList;
  410.             SelectVideoModeDialog;
  411.           end;
  412.         cmVideoTests: VideoTestsDialog(VideoTypesToCheck);
  413.         else
  414.           Exit;
  415.       end;
  416.       ClearEvent(Event);
  417.       CalcLinesMenu;
  418.     end;
  419.   end;
  420.  
  421.  
  422.   (*******************************************************************
  423.     Menu bar
  424.   *******************************************************************)
  425.   procedure TResDemoApp.InitMenubar;
  426.     var
  427.       R : TRect;
  428.   begin
  429.     GetExtent(R);
  430.     R.B.Y:=R.A.Y+1;
  431.     MenuBar:=New(PMenuBar, Init(R, NewMenu(
  432.       NewSubMenu('~F~ile', hcNoContext, NewMenu(
  433.         NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcDosShell,
  434.         NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
  435.         Nil))),
  436.       NewSubMenu('~V~ideo', hcVideo,
  437.         StorePointer(LinesMenu, NewMenu(          (* Create it later *)
  438.         Nil)),
  439.       NewSubMenu('~O~ptions', hcNoContext, NewMenu(
  440.         NewItem('~C~olors...', '', kbNoKey, cmColor, hcOColors,
  441.         NewItem('~P~alette...', '', kbNoKey, cmPalette, hctoyOVideoPalette,
  442.         NewItem('~V~ideo detection...', '', kbNoKey, cmVideoTests, hctoyOVideoTests,
  443.         Nil)))),
  444.     Nil))))));
  445.     CheckScanLines;
  446.     CalcLinesMenu;
  447.   end;
  448.  
  449.  
  450.   (*******************************************************************
  451.     Demonstration Status line. Uses some DOS 6 Help keys
  452.   *******************************************************************)
  453.   procedure TResDemoApp.InitStatusLine;
  454.     var
  455.       R: TRect;
  456.   begin
  457.     GetExtent(R);
  458.     R.A.Y := R.B.Y - 1;
  459.     New(StatusLine, Init(R,
  460.       StdStatusHelp(                  (* It's in TOYPREFS.PAS *)
  461.       NewStatusDef(0, $FFFF,
  462.         StdStatusKeys(
  463.         NewStatusKey('~F1~ Help',    kbF1,   cmHelp,
  464.         NewStatusKey('~Alt+X~ Exit', kbAltX, cmQuit,
  465.       Nil))),
  466.     Nil))));
  467.   end;
  468.  
  469.  
  470.   (*******************************************************************
  471.     Store CFG file
  472.   *******************************************************************)
  473.   procedure TResDemoApp.StoreCfg;
  474.     var
  475.       S:TDosStream;
  476.   begin
  477.     S.Init(ExeDir+CfgName, stCreate);
  478.     S.Write(VideoTypesToCheck, SizeOf(VideoTypesToCheck));
  479.     StoreVideoState(S);
  480.     S.Done;
  481.  
  482.     if (S.Status<>stOK) and (Application<>Nil) then
  483.       MessageBox(^C'Could not create comfiguration file', Nil, mfError+mfOKButton);
  484.   end;
  485.  
  486.  
  487.   (*******************************************************************
  488.     Ask user what video detection we want
  489.  
  490.     You might feel inclined to add this:
  491.  
  492.       VESAVersion:=0;
  493.       Video7:=False;
  494.       CheckVideoType;
  495.       ScreenMode:=GetScreenMode;      { This one is important }
  496.  
  497.     This might break the VideoState code: if V7 and VESA was enabled
  498.     at start-up and later denied, the wrong video call will be
  499.     made. If the program started in an extended video mode,
  500.     returning to DOS won't set the right video mode.
  501.     The above requires a complete application restart, video wise.
  502.   *******************************************************************)
  503.   procedure TResDemoApp.VideoTestsDialog(VT:SpecialVideoTypes);
  504.     {$I CheckVT}
  505.   begin
  506.     if ExecuteDialog(MakeVideoTestDialog, @VT)=cmOK then
  507.     begin
  508.       VideoTypesToCheck:=VT;
  509.       CheckVideoType;
  510.     end;
  511.   end;
  512.  
  513.  
  514.     (*******************************************************************
  515.     *******************************************************************)
  516.  
  517.   var
  518.     ResDemoApp : TResDemoApp;
  519.  
  520. begin
  521.   ResDemoApp.Init;
  522.   ResDemoApp.Run;
  523.   ResDemoApp.StoreCfg;
  524.   ResDemoApp.Done;
  525. end.
  526.  
  527.  
  528.