home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast.iso
/
pcmag
/
vol9n21.zip
/
PRISMENU.INC
< prev
next >
Wrap
Text File
|
1990-10-06
|
18KB
|
455 lines
{ ========================================================================= }
{ PRISMENU.INC }
{ ========================================================================= }
{ PrismMenu/MagMenu Declarations ========================================== }
{ Code generated by MakeMenu. }
CONST
{Color set used by menu system}
MenuColors : ColorSet = (
TextColor : BlackOnCyan; TextMono : LtGrayOnBlack;
CtrlColor : YellowOnBlue; CtrlMono : WhiteOnBlack;
FrameColor : BlackOnCyan; FrameMono : LtGrayOnBlack;
HeaderColor : WhiteOnCyan; HeaderMono : BlackOnLtGray;
ShadowColor : DkGrayOnBlack; ShadowMono : WhiteOnBlack;
HighlightColor : WhiteOnRed; HighlightMono : BlackOnLtGray;
PromptColor : BlackOnCyan; PromptMono : LtGrayOnBlack;
SelPromptColor : BlackOnCyan; SelPromptMono : LtGrayOnBlack;
ProPromptColor : BlackOnCyan; ProPromptMono : LtGrayOnBlack;
FieldColor : YellowOnBlue; FieldMono : LtGrayOnBlack;
SelFieldColor : BlueOnCyan; SelFieldMono : WhiteOnBlack;
ProFieldColor : LtGrayOnBlue; ProFieldMono : LtGrayOnBlack;
ScrollBarColor : CyanOnBlue; ScrollBarMono : LtGrayOnBlack;
SliderColor : CyanOnBlue; SliderMono : WhiteOnBlack;
HotSpotColor : BlackOnCyan; HotSpotMono : BlackOnLtGray;
BlockColor : YellowOnCyan; BlockMono : WhiteOnBlack;
MarkerColor : WhiteOnMagenta; MarkerMono : BlackOnLtGray;
DelimColor : BlueOnCyan; DelimMono : WhiteOnBlack;
SelDelimColor : BlueOnCyan; SelDelimMono : WhiteOnBlack;
ProDelimColor : BlueOnCyan; ProDelimMono : WhiteOnBlack;
SelItemColor : WhiteOnBlue; SelItemMono : BlackOnLtGray;
ProItemColor : CyanOnCyan; ProItemMono : BlackOnBlack;
HighItemColor : RedOnCyan; HighItemMono : WhiteOnBlack;
AltItemColor : WhiteOnBlue; AltItemMono : WhiteOnBlack;
AltSelItemColor : WhiteOnCyan; AltSelItemMono : BlackOnLtGray;
FlexAHelpColor : WhiteOnBlue; FlexAHelpMono : WhiteOnBlack;
FlexBHelpColor : WhiteOnBlue; FlexBHelpMono : WhiteOnBlack;
FlexCHelpColor : LtCyanOnBlue; FlexCHelpMono : BlackOnLtGray;
UnselXrefColor : YellowOnBlue; UnselXrefMono : LtBlueOnBlack;
SelXrefColor : WhiteOnMagenta; SelXrefMono : BlackOnLtGray;
MouseColor : WhiteOnRed; MouseMono : BlackOnLtGray
);
{ Menu Item Constants ===================================================== }
{Menu item constants from MAGMENU}
const
miHelp1 = 1;
miKeypad2 = 2;
miMouse3 = 3;
miAbout4 = 4;
miAbout5 = 5;
miUsing6 = 6;
miReferences7 = 7;
miCopyright8 = 8;
miOptions9 = 9;
miSound10 = 10;
miMouse11 = 11;
miDissolve12 = 12;
miPalettes13 = 13;
miUndo14 = 14;
miSwap15 = 15;
miRestore16 = 16;
miNew17 = 17;
miDuplicate18 = 18;
miLoad19 = 19;
miSave20 = 20;
miQuit21 = 21;
miYesExit22 = 22;
miNoResume23 = 23;
{ ========================================================================= }
{ ErrorHandler ============================================================ }
{$F+}
PROCEDURE ErrorHandler(UnitCode : Byte; var ErrCode : Word; Msg : string);
{-Report errors}
VAR
vip, vcs : word;
BEGIN
RingBell;
Inline ($8B/$46/$02/ { MOV AX,[BP+2] }
$89/$86/vip/ { MOV vip,AX }
$8B/$46/$04/ { MOV AX,[BP+4] }
$89/$86/vcs); { MOV vcs,AX }
FastWrite ('ERROR: '+Long2Str(ErrCode)+' in Unit '+Long2Str(UnitCode)+
' at address '+hexW(vcs-Cseg)+':'+hexW(vip)+'.',
1, 1, $4E);
if ReadKey = #0 then;
END;
{ DisplayHelp ============================================================= }
PROCEDURE DisplayHelp (UnitCode : Byte;
IdPtr : Pointer;
HelpIndex : Word);
{ Display context sensitive help}
BEGIN
if HelpIndex <> 0 then
with PrismHelp do begin
SetTopic (HelpIndex);
Process;
Erase;
end;
END;
{ CustomItemString ======================================================== }
PROCEDURE CustomItemString (VAR S : string;
Key : longint;
Selected, Highlighted : boolean;
WPtr : RawWindowPtr);
CONST
MouseState : array [0..3] of string [6] = (' Slow', 'Normal',
' Fast', ' Zoom!');
VAR
Len : byte absolute S;
S1 : string;
L1 : byte absolute S1;
BEGIN
{
This routine shows the existing state of the options within the menu.
Each menu press will change the state of the default. When the routine
exits, it sets a flag indicating that the defaults must be rewritten to
a disk file.
}
Case Key of
miSound10 : move (FlagArray [SfxFlag, 1], S [Len - 2], 3);
miMouse11 : begin
move (MouseState [MouseSpeed, 1], S [Len - 5], 6);
end;
miDissolve12 : begin
S1 := Num2Str (FadeRateArray [DissolveDelay]);
Move (S1 [1], S [Len - pred (L1)], L1);
end;
end;
END;
{$F-}
{ InitMenu ================================================================ }
FUNCTION InitMenu(var M : Menu) : Word;
{-Initialize menu system generated by MAKEMENU}
CONST
{Frame constants}
Frame1 : FrameArray = '┌└┐┘──││';
BEGIN
With M do begin
if not InitCustom(1, 24, 80, 24, MenuColors,
wClear+wUserContents+wCoversOnDemand,
Horizontal) then begin
InitMenu := InitStatus;
Exit;
end;
mnOptionsOn(mnAlphaMatch+mnSelectOnMatch+mnAllowPending+mnArrowSelect+
mnAllHotSpots+mnUseItemForTopic+mnSelectOnClick);
mnOptionsOff(mnPopOnSelect);
AddItemHelp(' Help ', 3, 2, miHelp1,
' Help with this program.');
AddFramedSubMenu(2, 14, 21, 22, Vertical, Frame1);
SetNormAttr(BlackOnLtGray, LtGrayOnBlack);
SetHighAttr(RedOnLtGray, WhiteOnBlack);
SetProtectAttr(LtGrayOnLtGray, BlackOnBlack);
SetFrameAttr(BlackOnLtGray, LtGrayOnBlack);
SetHeaderAttr(WhiteOnLtGray, BlackOnLtGray);
AddShadow(shBR, shSeeThru);
AddSeparator('├', '─', '┤', 3);
AddSeparator('├', '─', '┤', 7);
AddItemHelp('Keypad Editing', 1, 1, miKeypad2,
' How to edit a palette of colors using the number pad keys.');
AddItemHelp('Mouse Editing', 2, 1, miMouse3,
' How to edit a palette of colors using the mouse.');
AddItemHelp('About the VGA', 4, 11, miAbout4,
' How the Video Graphics Array works. ');
AddItemHelp('About This Program', 5, 12, miAbout5,
' How this program was developed -- and why.');
AddItemHelp('Using This Program', 6, 1, miUsing6,
' How to make the best use of this program.');
AddItemHelp('References', 8, 1, miReferences7,
' Where to find more information about programming the VGA display. ');
AddItemHelp('Copyright', 9, 1, miCopyright8,
' PRISM, v1.0. This version copyright (c) 1990 Ziff Communications Co.');
ItemsDone;
AddItemHelp(' Options ', 15, 2, miOptions9,
' Reset the defaults for sound effects, mouse speed, and dissolve rate. ');
AddFramedSubMenu(14, 20, 33, 22, Vertical, Frame1);
SetNormAttr(BlackOnLtGray, LtGrayOnBlack);
SetHighAttr(RedOnLtGray, WhiteOnBlack);
SetProtectAttr(LtGrayOnLtGray, BlackOnBlack);
SetFrameAttr(BlackOnLtGray, LtGrayOnBlack);
SetHeaderAttr(WhiteOnLtGray, BlackOnLtGray);
AddShadow(shBR, shSeeThru);
AddItemHelp('Sound Effects', 1, 1, miSound10,
' Toggle sound effects on or off.');
AddItemHelp('Mouse Speed', 2, 1, miMouse11,
' Change the default speed for moving the mouse.');
AddItemHelp('Dissolve Rate', 3, 1, miDissolve12,
' Set the number of steps to fade from one color to another.');
ItemsDone;
AddItemHelp(' Palettes ', 31, 2, miPalettes13,
' Generate a NEW (random) palette, DUPLICATE a color, UNDO, RESTORE, or SWAP.');
AddFramedSubMenu(30, 18, 44, 22, Vertical, Frame1);
SetNormAttr(BlackOnLtGray, LtGrayOnBlack);
SetHighAttr(RedOnLtGray, WhiteOnBlack);
SetProtectAttr(LtGrayOnLtGray, BlackOnBlack);
SetFrameAttr(BlackOnLtGray, LtGrayOnBlack);
SetHeaderAttr(WhiteOnLtGray, BlackOnLtGray);
AddShadow(shBR, shSeeThru);
AddItemHelp('Undo ^U', 1, 1, miUndo14,
' Undo the last change. Repeated calls will undo the last 12 changes.');
AddItemHelp('Swap ^S', 2, 1, miSwap15,
' Swap two colors within a palette. Select source color, then target.');
AddItemHelp('Restore ^R', 3, 1, miRestore16,
' Restore the system palette that was active when the program began.');
AddItemHelp('New ^N', 4, 1, miNew17,
' Generate a totally random palette of colors. ');
AddItemHelp('Duplicate ^D', 5, 1, miDuplicate18,
' Duplicate a color. Select source color, then target.');
ItemsDone;
AddItemHelp(' Load ', 48, 2, miLoad19,
' Load a palette of colors.');
AddItemHelp(' Save ', 61, 2, miSave20,
' Save a palette of colors.');
AddItemHelp(' Quit ', 73, 2, miQuit21,
' Exit the program, return to DOS.');
AddFramedSubMenu(61, 21, 79, 22, Vertical, Frame1);
SetNormAttr(YellowOnRed, LtGrayOnBlack);
SetSelectAttr(WhiteOnBlack, BlackOnLtGray);
SetHighAttr(WhiteOnRed, WhiteOnBlack);
SetProtectAttr(LtGrayOnLtGray, BlackOnBlack);
SetFrameAttr(LtRedOnRed, LtGrayOnBlack);
SetHeaderAttr(YellowOnRed, BlackOnLtGray);
AddShadow(shBR, shSeeThru);
AddItemHelp('Yes. Exit to DOS', 1, 1, miYesExit22,
' Do you really want to quit this program?');
AddItemHelp('No. Resume Work', 2, 1, miNoResume23,
' No. Do not quit.');
ItemsDone;
ItemsDone;
MenuCommands.SetHelpProc (DisplayHelp); { show help on demand }
mnOptionsOn (mnUseItemForTopic); { menu item sets help topic }
SetCustomStringProc (CustomItemString); { show option states }
SetErrorProc (ErrorHandler); { error msgs }
InitMenu := RawError;
end; { with M do }
END;
{ InitHelpLine ============================================================ }
FUNCTION InitHelpLine(var H : RawWindow) : Word;
{-Initialize window for the help line}
CONST
Row : byte = 25;
BEGIN
if not H.InitCustom (1, Row, ScreenWidth, Row,
MenuColors, wClear) then begin
InitHelpLine := InitStatus;
Exit;
end;
H.SetTextAttr (LtBlueOnBlack, LtGrayOnBlack);
InitHelpLine := 0;
END;
{ UpdateHelpLine ========================================================== }
{$F+}
PROCEDURE UpdateHelpLine (CurrentItem : MenuItemNodePtr; MPtr : MenuPtr);
{-Update HelpLine for each menu item}
VAR
S : String;
BEGIN
if CurrentItem = nil then
S := ''
else
S := CurrentItem^.HelpString;
H.wFastText(Pad(S, H.Width), 1, 1);
END;
{$F-}
{ ========================================================================= }
{ ========================================================================= }
{ Help System }
{ ========================================================================= }
{ GetHelp ================================================================= }
PROCEDURE GetHelp (HelpIndex : word);
VAR
Finished : boolean;
StoreMouseRoutine : pointer;
StoreMouseRoutineEvent : MouseEventType;
BEGIN
StoreMouseRoutine := MouseRoutine;
StoreMouseRoutineEvent := MouseRoutineEvent;
SetMouseEventHandler (DisableEventHandler, nil);
{ Loop through help system }
Finished := false;
repeat
{ Display master index, pick help topic }
PrismHelp.SetTopic (HelpIndex);
PrismHelp.Process;
Case PrismHelp.GetLastCommand of
ccError,
ccQuit : Finished := true;
ccSelect : begin
PrismHelp.SetTopic (PrismHelp.GetTopicChoice);
repeat
PrismHelp.Process;
Case PrismHelp.GetLastCommand of
ccError : Finished := true;
ccQuit : if not PrismHelp.InHelpMode then
{ escape from pick window within help }
Finished := true;
end; { case }
until
Finished or (PrismHelp.GetLastCommand = ccQuit);
end;
end; { case }
until
Finished;
PrismHelp.Erase;
SetMouseEventHandler (StoreMouseRoutineEvent, StoreMouseRoutine);
END;
{ ========================================================================= }
{ ========================================================================= }
{ Pick list functions }
{ ========================================================================= }
{ CustomDirListFormat ===================================================== }
{$F+}
PROCEDURE CustomDirListFormat (VAR X : DirRec; VAR pkCat : byte;
VAR S : string; D : DirListPtr);
{$F-}
{ Show only name of palette file, no extension. }
BEGIN
S := Pad (' ' + JustName (X.Name), 10); { final string }
pkCat := pkNormal; { return normal cat }
END;
{ ========================================================================= }
{ DirectoryList =========================================================== }
FUNCTION PickFile : string;
{ Gets directory, selects a file. }
VAR
Dir : dirlist;
Result,
Count : word;
ExitFlag : boolean;
EraseFile : file;
EraseFileName : string;
EraseFileAttr : word;
StoreMouseRoutine : pointer;
StoreMouseRoutineEvent : MouseEventType;
BEGIN
PickFile := '';
With Dir do begin
if not InitCustom (5, 5, 77, 21,
MenuColors,
DefWindowOptions or wBordered,
MaxAvail,
PickSnaking,
SingleFile)
then begin
WriteLn ('Failed to init DirList, Status = ', InitStatus);
halt;
end;
{ Add mouse support }
if MouseInstalled then begin
PickCommands.cpOptionsOn (cpEnableMouse);
StoreMouseRoutine := MouseRoutine; { store event handler }
StoreMouseRoutineEvent := MouseRoutineEvent;
MouseRoutine := nil; { disable event handler }
EnableEventHandling;
end;
{ Set desired DirList features }
wframe.AddShadow (shBr, shSeeThru);
SetPosLimits (1,1, ScreenWidth, pred (ScreenHeight));
SetPadSize (1,1);
diOptionsOn (diOPtimizeSize);
AddMaskHeader (True, 1, 30, heTC);
SetSortOrder (SortName);
SetUserFormat (10, CustomDirListFormat);
SetMask (ProgramPath + '*.Pal', ReadOnly);
SetSearchMode (PickAltStringSearch);
PreloadDirList;
Result := GetLastError;
end; { with Dir do begin }
if Result <> 0 then
PauseMsgBox ('Sorry. Error ' + Num2Str (Result) + ' has occurred. ' +
ProgramName + ' cannot load this directory.',
RedDbColorSet, dbJustify + dbShadow, 40)
else begin
Count := Dir.GetMatchingFileCount;
if Count = 0 then
PauseMsgBox ('Sorry. There are no palette files to load.',
RedDbColorSet, dbShadow, 50)
else begin
PickCommands.AddCommand (ccUser2, 1, KcF1, 0);
PickCommands.AddCommand (ccUser3, 1, KcCtrlU, 0);
ExitFlag := false;
repeat
Dir.Process;
case Dir.GetLastCommand of
ccSelect : begin
PickFile := ForceExtension (Dir.GetSelectedPath, 'PAL');
ExitFlag := true;
end;
ccError : FastWrite ('Error: ' + Long2Str (Dir.GetLastError),
ScreenHeight, 1, TextAttr);
ccQuit,
ccUser3 : ExitFlag := true;
ccUser2 : GetHelp (miLoad19);
end; { case }
until
ExitFlag;
end; { pick a file }
end; { if then else begin }
if MouseInstalled then begin
MouseRoutine := StoreMouseRoutine; { restore event handler }
MouseRoutineEvent := StoreMouseRoutineEvent;
end;
Dir.Done;
END;
{ ========================================================================= }
{ ========================================================================= }