Menu
▾
▴
[Win32forth-cvs] win32forth/apps/Sudoku Sudoku.f,1.3,1.4
|
From: Dirk B. <db...@us...> - 2005-11-06 09:17:31
|
Update of /cvsroot/win32forth/win32forth/apps/Sudoku In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24995/apps/Sudoku Modified Files: Sudoku.f Log Message: Changed the ChooseFont: and ChooseColor: methods of the Frame-Window object to use the Choose: methods of the gdiClass library. Index: Sudoku.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Sudoku/Sudoku.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Sudoku.f 3 Nov 2005 19:21:01 -0000 1.3 --- Sudoku.f 6 Nov 2005 09:17:22 -0000 1.4 *************** *** 6,10 **** anew -Sudoku.f ! Create SudokuVersion ," 1.2" s" apps\Sudoku" "fpath+ s" apps\Sudoku\res" "fpath+ --- 6,10 ---- anew -Sudoku.f ! Create SudokuVersion ," 1.3" s" apps\Sudoku" "fpath+ s" apps\Sudoku\res" "fpath+ *************** *** 77,81 **** 0 Width: SudokuFont 700 Weight: SudokuFont - \ 0 PitchAndFamily: SudokuFont : ChangeFontSize ( n -- ) dup to FontHeight Height: SudokuFont Create: SudokuFont ; : SetFontSize ( -- ) size 6 8 */ negate ChangeFontSize ; \ set font size to a fixed fraction of cell size --- 77,80 ---- *************** *** 114,118 **** +z," 000000000000000000000000000000000000000000000000000000000000000000000000000000000" : SetColours ( -- ) 81 0 DO Numbers 81 + i + c@ '0' = IF 1 ELSE 0 THEN Numbers 243 + i + c! LOOP ; - \ SetColours Create TempNumbers 81 allot : Start>Solution numbers 81 + numbers 81 move ; --- 113,116 ---- *************** *** 206,210 **** : BlankAll ( -- ) Numbers 243 '0' fill Numbers 243 + 81 1 fill ; \ to make new game - \ : ClearAll ( -- ) Numbers 81 + Numbers 162 + 81 move ; : ClearAll ( -- ) 81 0 DO Numbers 81 + i + c@ dup Numbers 162 + i + c! \ to restart game '0' = IF 1 ELSE 0 THEN Numbers 243 + i + c! --- 204,207 ---- *************** *** 335,339 **** : OpenFile ( Filename$ -- f ) dup dup c@ \ true on success IF count r/o open-file - \ IF 3drop false ( ReadErrorMessage ) \ file does not exist IF drop ReadErrorMessage false \ file does not exist ELSE to FileHandle --- 332,335 ---- *************** *** 350,354 **** : SaveFile ( Filename$ -- ) dup dup c@ IF count r/w create-file - \ IF 3drop false to SaveFlag ( WriteErrorMessage ) \ file does not exist IF drop WriteErrorMessage false to SaveFlag \ file does not exist ELSE to FileHandle --- 346,349 ---- *************** *** 431,490 **** :Object Frame <Super Window - Record: CHOOSEFONT - int lSize - int hOwner - int hDC - int lpLogFont - int iPointSize - int FontFlags - int rgbColors - 8 cells class-allot - ;RecordSize: sizeof(CHOOSEFONT) - :M ChooseFont: ( -- ) ! CHOOSEFONT call ChooseFont ! IF SetFontSize redraw: [ self ] THEN ! ;M ! ! 64 bytes CustomColors ! ! Record: CHOOSECOLOR ! int lStructSize ! int hwndOwner ! int Instance ! int rgbResult ! int lpCustColors ! int Flags ! 3 cells class-allot ! ;RecordSize: sizeof(CHOOSECOLOR) ! ! int ColorObject ! :M ChooseColor: ( object -- ) to ColorObject ! Color: ColorObject 16777215 and to rgbResult ! CHOOSECOLOR call ChooseColor ! IF rgbResult [ PC_NOCOLLAPSE 256 * 256 * 256 * ] literal or NewColor: ColorObject redraw: [ self ] THEN ! ;M :M Classinit: ( -- ) ClassInit: super \ init super class SudokuMenu to CurrentMenu - hWnd to hOwner - sizeof(CHOOSEFONT) to lSize - CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or to FontFlags - Sudokufont.LOGFONT to lpLogFont - - sizeof(CHOOSECOLOR) to lStructSize - hWnd to hwndOwner - [ Hex ] - E6FFFF CustomColors ! FFE6FF CustomColors 4 + ! FFFFE6 CustomColors 8 + ! - FFE6E6 CustomColors C + ! E6FFE6 CustomColors 10 + ! E6E6FF CustomColors 14 + ! - C8F0F0 CustomColors 18 + ! F0C8F0 CustomColors 1C + ! F0F0C8 CustomColors 20 + ! - F0C8C8 CustomColors 24 + ! C8F0C8 CustomColors 28 + ! C8C8F0 CustomColors 2C + ! - F0F0F0 CustomColors 30 + ! E6E6E6 CustomColors 34 + ! F4FFFF CustomColors 38 + ! - FFFFF4 CustomColors 3C + ! - [ Decimal ] - CustomColors to lpCustColors - CC_RGBINIT CC_FULLOPEN or to Flags ;M --- 426,442 ---- :Object Frame <Super Window :M ChooseFont: ( -- ) ! hWnd Choose: SudokuFont ! IF SetFontSize redraw: [ self ] ! THEN ;M ! :M ChooseColor: { ColorObject -- } ! Choose: ColorObject ! if redraw: [ self ] ! then ;M :M Classinit: ( -- ) ClassInit: super \ init super class SudokuMenu to CurrentMenu ;M *************** *** 539,543 **** CS_DBLCLKS GCL_STYLE hWnd Call SetClassLong drop 101 appinst Call LoadIcon GCL_HICON hWnd Call SetClassLong drop - \ 0 GCL_HCURSOR hWnd Call SetClassLong drop \ no, need default cursor for margin 0 GCL_HBRBACKGROUND hWnd Call SetClassLong drop 0 Call CreateCompatibleDC PutHandle: mdc --- 491,494 ---- *************** *** 598,602 **** : Draw9 { l t -- } l 2 + t 2 + size 3 * 2 - dup DrawRectangle \ extra line on inside - \ l t size 3 * 2 + dup DrawRectangle \ extra line on outside t 1+ size 3 * bounds DO l 1+ size 3 * bounds DO i j size size DrawRectangle size +LOOP --- 549,552 ---- *************** *** 606,610 **** Black LineColor: mdc LeftMargin TopMargin size 9 * 2 + dup DrawRectangle \ extra line on outside - \ LeftMargin 2 + TopMargin 2 + size 9 * 2 - dup DrawRectangle \ extra line on inside TopMargin size 9 * bounds DO LeftMargin size 9 * bounds DO i j Draw9 size 3 * +LOOP --- 556,559 ---- *************** *** 681,689 **** :M On_Paint: ( -- ) - \ SaveDC: dc SRCCOPY 0 0 GetHandle: mdc Width Height StatusBarHeight - ToolbarHeight - 0 ToolbarHeight BitBlt: dc - \ RestoreDC: dc ;M --- 630,636 ---- *************** *** 902,916 **** Resize: Frame ; IDM_TOGGLE_TOOLBAR SetCommand : OnFont ( -- ) ChooseFont: Frame ; IDM_FONT SetCommand ! : TextColour1 ( -- ) TextColor1 ChooseColor: frame ; IDM_TEXT_COLOUR_1 SetCommand ! : TextColour2 ( -- ) TextColor2 ChooseColor: frame ; IDM_TEXT_COLOUR_2 SetCommand ! : TextColour3 ( -- ) TextColor3 ChooseColor: frame ; IDM_TEXT_COLOUR_3 SetCommand ! : TextColour4 ( -- ) TextColor4 ChooseColor: frame ; IDM_TEXT_COLOUR_4 SetCommand ! : FixedColour ( -- ) FixedColor ChooseColor: frame ; IDM_FIXED_COLOUR SetCommand ! : WarningColour ( -- ) WarningColor ChooseColor: frame ; IDM_WARNING_COLOUR SetCommand : VariableBackgroundColour ( -- ) VariableBackgroundColor ChooseColor: frame ; IDM_VARIABLE_BACKGROUND_COLOUR SetCommand ! : FixedBackgroundColour ( -- ) FixedBackgroundColor ChooseColor: frame ; IDM_FIXED_BACKGROUND_COLOUR SetCommand ! : HighLightColour ( -- ) HighLightColor ChooseColor: frame ; IDM_HIGHLIGHT_COLOUR SetCommand ! : MarginColour ( -- ) MarginColor ChooseColor: frame ; IDM_MARGIN_COLOUR SetCommand ! : EliminationColour ( -- ) EliminationColor ChooseColor: frame ; IDM_ELIMINATION_COLOUR SetCommand \ Game Menu --- 849,864 ---- Resize: Frame ; IDM_TOGGLE_TOOLBAR SetCommand : OnFont ( -- ) ChooseFont: Frame ; IDM_FONT SetCommand ! ! : TextColour1 ( -- ) TextColor1 ChooseColor: frame ; IDM_TEXT_COLOUR_1 SetCommand ! : TextColour2 ( -- ) TextColor2 ChooseColor: frame ; IDM_TEXT_COLOUR_2 SetCommand ! : TextColour3 ( -- ) TextColor3 ChooseColor: frame ; IDM_TEXT_COLOUR_3 SetCommand ! : TextColour4 ( -- ) TextColor4 ChooseColor: frame ; IDM_TEXT_COLOUR_4 SetCommand ! : FixedColour ( -- ) FixedColor ChooseColor: frame ; IDM_FIXED_COLOUR SetCommand ! : WarningColour ( -- ) WarningColor ChooseColor: frame ; IDM_WARNING_COLOUR SetCommand : VariableBackgroundColour ( -- ) VariableBackgroundColor ChooseColor: frame ; IDM_VARIABLE_BACKGROUND_COLOUR SetCommand ! : FixedBackgroundColour ( -- ) FixedBackgroundColor ChooseColor: frame ; IDM_FIXED_BACKGROUND_COLOUR SetCommand ! : HighLightColour ( -- ) HighLightColor ChooseColor: frame ; IDM_HIGHLIGHT_COLOUR SetCommand ! : MarginColour ( -- ) MarginColor ChooseColor: frame ; IDM_MARGIN_COLOUR SetCommand ! : EliminationColour ( -- ) EliminationColor ChooseColor: frame ; IDM_ELIMINATION_COLOUR SetCommand \ Game Menu *************** *** 1121,1125 **** rtMargin 12 + 100 REG_DWORD RegEntry "MarginBottom" ' CurrentTextColour 4 + 1 REG_DWORD RegEntry "CurrentTextColour" ! Frame.CustomColors 64 2dup REG_BINARY RegEntry "CustomColors" FixedColor dup @ REG_DWORD RegEntry "FixedColour" TextColor1 dup @ REG_DWORD RegEntry "TextColour1" --- 1069,1073 ---- rtMargin 12 + 100 REG_DWORD RegEntry "MarginBottom" ' CurrentTextColour 4 + 1 REG_DWORD RegEntry "CurrentTextColour" ! CustomColors: FixedColor 2dup REG_BINARY RegEntry "CustomColors" FixedColor dup @ REG_DWORD RegEntry "FixedColour" TextColor1 dup @ REG_DWORD RegEntry "TextColour1" *************** *** 1238,1248 **** Create MessageStructure 32 allot - (( - : Pause ( -- ) \ instead of "Winpause" - BEGIN PM_REMOVE 0 0 0 MessageStructure Call PeekMessage - WHILE MessageStructure HandleMessages drop - REPEAT - ; - )) : MessageLoop ( -- ) \ instead of "Begin key drop again" BEGIN 0 0 0 MessageStructure Call GetMessage --- 1186,1189 ---- *************** *** 1254,1259 **** : Su ( -- ) - \ LOGPIXELSX condc Call GetDeviceCaps to Resolution \ Resolution of screen - \ 96 100 145 */ to Resolution \ pixels per inch 96 to Resolution \ needs to be adjusted to make print size same as screen size DefaultPrinter --- 1195,1198 ---- *************** *** 1267,1273 **** Color: MarginColor MarginColor off NewColor: MarginColor Start: Frame - \ ZeroMoves - \ StartTimer - \ SelectBlank Colour1 RestoreRecentFiles --- 1206,1209 ---- *************** *** 1278,1282 **** ShowElimination check: hEliminate Directory count 2dup SetDir: OpenDialog SetDir: SaveDialog - \ 6 SetNumber: RecentFiles NumberRecentFiles SetNumber: RecentFiles SudokuAccelerators EnableAccelerators --- 1214,1217 ---- *************** *** 1284,1296 **** ; ! [defined] VIMAGE [if] also VIMAGE [then] ! [defined] CONSOLE-DLL? [if] false to CONSOLE-DLL? [then] ! ' Su turnkey Sudoku.exe ! needs SudokuResources ! \ cr .( Do you want to associate .sku files with Sudoku.exe [Y/N]: ) key dup emit dup 121 = swap 89 = or nostack ! \ [IF] ! \ Needs FileAssociations ! \ s" .sku" s" Sudoku File" s" Sudoku.exe" SetAssociation ! \ [THEN] ! 1 pause-seconds bye --- 1219,1226 ---- ; ! [defined] VIMAGE [if] also VIMAGE [then] ! [defined] CONSOLE-DLL? [if] false to CONSOLE-DLL? [then] ! ' Su turnkey Sudoku.exe ! needs SudokuResources ! 1 pause-seconds bye |
