Menu
▾
▴
[Win32forth-cvs] win32forth/apps/Solipon2 About.f, NONE, 1.1 FileIO.f, NONE, 1.1 Menu.f, NONE, 1.1 Print.f, NONE, 1.1 Sound.f, NONE, 1.1 SOLIPION.F, 1.7, 1.8
|
From: Dirk B. <db...@us...> - 2008-04-30 15:58:11
|
Update of /cvsroot/win32forth/win32forth/apps/Solipon2 In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8219 Modified Files: SOLIPION.F Added Files: About.f FileIO.f Menu.f Print.f Sound.f Log Message: - Major CleanUp of Solipion. --- NEW FILE: Sound.f --- \ $Id: Sound.f,v 1.1 2008/04/30 15:58:01 dbu_de Exp $ WinLibrary winmm.dll 0 value <hypothesis>busy? 0 value <hypothesis>handle 0 value <hypothesis>flag? 0 value <hypothesis>size : playthat SND_ASYNC SND_MEMORY or SND_NODEFAULT or NULL ROT Call PlaySound drop ; : find-file ( addr len -- addr1 len1 ) search-path off \ clear path list s" ." "fpath+ \ current dir is first &forthdir count "fpath+ s" apps\Solipon2" "fpath+ "path-file drop ; : <<<hypothesis>>> ( -- ) <hypothesis>busy? ?exit true to <hypothesis>busy? <hypothesis>flag? 0= if true to <hypothesis>flag? s" ep7.wav" find-file r/o open-file drop >r r@ file-size drop d>s to <hypothesis>size r@ <hypothesis>size malloc to <hypothesis>handle <hypothesis>handle <hypothesis>size r@ read-file 2drop r> close-file drop then <hypothesis>flag? music? and if <hypothesis>handle playthat then false to <hypothesis>busy? ; 0 value <ding>busy? 0 value <ding>handle 0 value <ding>flag? 0 value <ding>size : <<<ding>>> ( -- ) <ding>busy? ?exit true to <ding>busy? <ding>flag? 0= if true to <ding>flag? s" av7.wav" find-file r/o open-file drop >r r@ file-size drop d>s to <ding>size r@ <ding>size malloc to <ding>handle <ding>handle <ding>size r@ read-file 2drop r> close-file drop then <ding>flag? music? and if <ding>handle playthat then false to <ding>busy? ; 0 value <bleep1>busy? 0 value <bleep1>handle 0 value <bleep1>flag? 0 value <bleep1>size : <<<bleep1>>> ( -- ) <bleep1>busy? ?exit true to <bleep1>busy? <bleep1>flag? 0= if true to <bleep1>flag? s" bleep7.wav" find-file r/o open-file drop >r r@ file-size drop d>s to <bleep1>size r@ <bleep1>size malloc to <bleep1>handle <bleep1>handle <bleep1>size r@ read-file 2drop r> close-file drop then <bleep1>flag? music? and if <bleep1>handle playthat then false to <bleep1>busy? ; 0 value <yahoo>busy? 0 value <yahoo>handle 0 value <yahoo>flag? 0 value <yahoo>size : <<<yahoo>>> ( -- ) <yahoo>busy? ?exit true to <yahoo>busy? <yahoo>flag? 0= if true to <yahoo>flag? s" yahoo.wav" find-file r/o open-file drop >r r@ file-size drop d>s to <yahoo>size r@ <yahoo>size malloc to <yahoo>handle <yahoo>handle <yahoo>size r@ read-file 2drop r> close-file drop then <yahoo>flag? music? and if <yahoo>handle playthat then false to <yahoo>busy? ; 0 value <applause>busy? 0 value <applause>handle 0 value <applause>flag? 0 value <applause>size : <<<applause>>> ( -- ) <applause>busy? ?exit true to <applause>busy? <applause>flag? 0= if true to <applause>flag? s" applause7.wav" find-file r/o open-file drop >r r@ file-size drop d>s to <applause>size r@ <applause>size malloc to <applause>handle <applause>handle <applause>size r@ read-file 2drop r> close-file drop then music? <applause>flag? and if <applause>handle playthat then false to <applause>busy? ; --- NEW FILE: FileIO.f --- \ $Id: FileIO.f,v 1.1 2008/04/30 15:58:01 dbu_de Exp $ FileOpenDialog OpenGame "Open Game" "SoliPion (*.SOL)|*.SOL|All (*.*)|*.*|" FileSaveDialog SaveGame "Save Game" "SoliPion (*.SOL)|*.SOL|All (*.*)|*.*|" \ --------------------------------------------------------------- \ Open a Game \ --------------------------------------------------------------- defer !bests : nothing false ; ' nothing is !bests 0 value gameloaded? : open-game { \ open$ hfile -- } max-path LocalAlloc: open$ GetHandle: SOLIPIONW Start: OpenGame dup c@ \ ( -- a1 n1 ) IF count open$ place open$ count r/w open-file abort" open-file" to hfile smallstring 19 hfile read-file 2drop smallstring 3 s" SOL" compare 0= dup if true to put-by? then smallstring 3 s" PLA" compare 0= dup if false to put-by? then or IF string-player-name 20 hfile read-file 2drop &of shift-x cell hfile read-file 2drop &of shift-y cell hfile read-file 2drop &of moves cell hfile read-file 2drop moves-table moves cells hfile read-file 2drop THEN true to show? moves 1- dup dup max-counter > if to max-counter to counter !bests else 2drop then hfile close-file drop true to gameloaded? ELSE DROP THEN ; \ --------------------------------------------------------------- \ Re-Open the game \ --------------------------------------------------------------- : (re-open-game) { \ open$ hfile -- } max-path LocalAlloc: open$ in-memory? IF counter 1+ to moves ELSE S" GAME.SOL" open$ place open$ count r/w open-file abort" open-file" to hfile smallstring 3 hfile read-file 2drop smallstring 3 s" SOL" compare 0= dup if true to put-by? then smallstring 3 s" PLA" compare 0= dup if false to put-by? then or IF smallstring 16 hfile read-file 2drop string-player-name 20 hfile read-file 2drop &of shift-x cell hfile read-file 2drop &of shift-y cell hfile read-file 2drop &of moves cell hfile read-file 2drop moves-table moves cells hfile read-file 2drop THEN hfile close-file drop THEN 0 to tempo false to show? ; ' (re-open-game) is re-open-game \ --------------------------------------------------------------- \ Save the Game \ --------------------------------------------------------------- : (save-game) { \ save$ hfile -- } max-path LocalAlloc: save$ \ in-memory? if counter 1+ to moves else s" GAME.SOL" save$ place save$ count r/w create-file abort" create-file" to hfile put-by? if s" PLA" else s" SOL" then hfile write-file drop get-local-time time-buf 16 hfile write-file drop string-player-name 20 hfile write-file drop &of shift-x cell hfile write-file drop &of shift-y cell hfile write-file drop counter 1+ to moves &of moves cell hfile write-file drop moves-table moves cells hfile write-file drop hfile close-file drop then ; ' (save-game) is save-game \ --------------------------------------------------------------- \ Save the Game As \ --------------------------------------------------------------- : save-game-as { \ hfile save$ -- } max-path LocalAlloc: save$ s" Save the Game As : " save$ place save$ count SetTitle: SaveGame auto-save? if counter 0 <# # # # #> save$ place s" .SOL" save$ +place save$ count delete-file drop save$ dup c@ else GetHandle: SOLIPIONW Start: SaveGame dup c@ \ ( -- a1 n1 ) then IF count r/w create-file abort" create-file" to hfile put-by? if s" SOL" else s" PLA" then hfile write-file drop get-local-time time-buf 16 hfile write-file drop string-player-name 20 hfile write-file drop &of shift-x cell hfile write-file drop &of shift-y cell hfile write-file drop counter 1+ to moves &of moves cell hfile write-file drop moves-table moves cells hfile write-file drop hfile close-file drop ELSE drop THEN ; \ --------------------------------------------------------------- \ Save the bests-table \ --------------------------------------------------------------- : save-bests { \ best$ hfile -- } max-path LocalAlloc: best$ S" solipion.dat" best$ place best$ count r/w open-file 0= if to hfile smallstring 3 hfile read-file 2drop else drop best$ count r/w create-file drop to hfile s" SOL" 2dup hfile write-file drop smallstring swap cmove get-local-time time-buf 16 hfile write-file drop then smallstring 3 s" SOL" compare 0= if stamper 16 hfile write-file drop bests-table 220 hfile write-file drop then hfile close-file drop ; --- NEW FILE: Print.f --- \ $Id: Print.f,v 1.1 2008/04/30 15:58:01 dbu_de Exp $ \ --------------------------------------------------------------- \ Print the Positions of the Game (text) \ --------------------------------------------------------------- create ligne$ 256 allot : #moves" { nmoves \ -- adr len } ligne$ 256 blank moves-table nmoves cells+ s" " ligne$ place dup c@ 0 <# # # #> ligne$ +place s" " ligne$ +place dup 1 + c@ 0 <# # # #> ligne$ +place s" " ligne$ +place dup 2 + c@ 0 <# # #> ligne$ +place s" " ligne$ +place 3 + c@ 0 <# # #> ligne$ +place ligne$ count ; : print-game { \ message$ -- } MAXSTRING localAlloc: message$ screen-width >r 680 to screen-width screen-height >r 484 to screen-height char-height >r 12 to char-height char-width >r 9 to char-width #pages-up ?dup IF 2 = IF two-page ELSE four-page THEN THEN start-scaled IF s" Courier New" SetPrinterFont: ThePrinter s" Score : " message$ place counter 0 (ud,.) message$ +place message$ count Type: ThePrinter Cr: ThePrinter s" Row Line Rank Direction" Type: ThePrinter Cr: ThePrinter counter 0 DO i #moves" Type: ThePrinter Cr: ThePrinter LOOP print-scaled single-page THEN r> to char-width r> to char-height r> to screen-height r> to screen-width ; \ --------------------------------------------------------------- \ Print the Bitmap of the Game \ --------------------------------------------------------------- DECIMAL 4 constant sizeof(RGBQUAD) 14 constant sizeof(BitmapFileHeader) 40 constant sizeof(BitmapInfoHeader) 0 constant biSize 4 constant biWidth 8 constant biHeight 12 constant biPlanes 14 constant biBitCount 16 constant biCompression 20 constant biSizeImage 24 constant biXPelsPerMeter 28 constant biYPelsPerMeter 32 constant biClrUsed 36 constant biClrImportant : print-demo-bmp { nBits \ pbmi lpBits hbm hdcMem -- } Open: ThePrinter GetHandle: ThePrinter 0= ?EXIT LandScape: ThePrinter Start: ThePrinter sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + malloc to pbmi pbmi sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + erase sizeof(BitmapInfoHeader) pbmi biSize + ! SCREEN-WIDTH pbmi biWidth + ! SCREEN-HEIGHT pbmi biHeight + ! 1 pbmi biPlanes + w! nBits pbmi biBitCount + w! BI_RGB pbmi biCompression + ! SCREEN-HEIGHT SCREEN-WIDTH GetHandle: solipion-dc Call CreateCompatibleBitmap to hbm GetHandle: solipion-dc Call CreateCompatibleDC to hdcMem hbm hdcMem Call SelectObject drop SRCCOPY 0 0 GetHandle: solipion-dc SCREEN-HEIGHT SCREEN-WIDTH 0 0 hdcMem Call BitBlt ?win-error DIB_RGB_COLORS pbmi NULL SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 1st GetDIBits" pbmi biSizeImage + @ malloc to lpBits lpBits pbmi biSizeImage + @ erase DIB_RGB_COLORS pbmi lpBits SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 2nd GetDIBits" SRCCOPY DIB_RGB_COLORS pbmi lpBits SCREEN-HEIGHT SCREEN-WIDTH 0 0 Height: ThePrinter 80 100 */ Width: ThePrinter 80 100 */ Height: ThePrinter 10 100 */ Width: ThePrinter 10 100 */ GetHandle: ThePrinter Call StretchDIBits GDI_ERROR = ABORT" StretchDIBits" 5 0 do Width: ThePrinter 8 100 */ i - Height: ThePrinter 8 100 */ i - MoveTo: ThePrinter Width: ThePrinter 92 100 */ i + Height: ThePrinter 8 100 */ i - LineTo: ThePrinter Width: ThePrinter 92 100 */ i + Height: ThePrinter 92 100 */ i + LineTo: ThePrinter Width: ThePrinter 8 100 */ i - Height: ThePrinter 92 100 */ i + LineTo: ThePrinter Width: ThePrinter 8 100 */ i - Height: ThePrinter 8 100 */ i - LineTo: ThePrinter loop End: ThePrinter Portrait: ThePrinter Close: ThePrinter hdcMem call DeleteDC ?win-error hbm call DeleteObject ?win-error lpBits release pbmi release ; --- NEW FILE: About.f --- \ $Id: About.f,v 1.1 2008/04/30 15:58:01 dbu_de Exp $ :Object AboutSolipion <SUPER dialog IDD_ABOUT_FORTH forthdlg find-dialog-id constant template create about-head z," Solipion Version: 2.0" create about-msg1 z," Written 2005 by:\n" +z," Bruno Gauthier\n" +z," eMail: bga...@fr...\n" +z," http:\\bgauthier.free.fr" create about-msg2 z," \n" +z," \n" +z," \n" +z," " create about-msg3 z," This is a Morpion Solitaire Game." :M On_Init: ( hWnd-focus -- f ) about-head zcount IDD_ABOUT_HEAD SetDlgItemText: self about-msg1 zcount IDD_ABOUT_TEXT SetDlgItemText: self about-msg2 zcount IDD_ABOUT_TEXT2 SetDlgItemText: self about-msg3 zcount IDD_ABOUT_TEXT3 SetDlgItemText: self 1 ;M :M On_Command: ( hCtrl code ID -- f1 ) CASE IDCANCEL OF 0 end-dialog ENDOF false swap ( default result ) ENDCASE ;M :M Start: ( -- f ) Addr: SolipionW template run-dialog ;M ;Object : about-solipion ( -- ) start: AboutSoliPion ; --- NEW FILE: Menu.f --- \ $Id: Menu.f,v 1.1 2008/04/30 15:58:01 dbu_de Exp $ ToolBar Solipion-Tool-Bar1 "SOLIPION.BMP" 0 PictureButton 'N' +k_control pushkey ; \ New ButtonInfo" New Game " 1 PictureButton 'O' +k_control pushkey ; \ Open ButtonInfo" Open " 1 PictureButton 'R' +k_control pushkey ; \ Re-open ButtonInfo" Re-Open " 2 PictureButton 'E' +k_control pushkey ; \ Save ButtonInfo" Save " 2 PictureButton 'S' +k_control pushkey ; \ Save As ButtonInfo" Save As " 3 PictureButton 'T' +k_control pushkey ; \ Print ButtonInfo" Print Text " 17 PictureButton 'B' +k_control pushkey ; \ Print bmp ButtonInfo" Print Bitmap " 11 PictureButton 'A' +k_control pushkey ; \ Automatic ButtonInfo" Automatic " 12 PictureButton k_left +k_control pushkey ; \ Shrinking ButtonInfo" Shrinking " 4 PictureButton k_right +k_control pushkey ; \ Enlarge ButtonInfo" Enlarge " 13 PictureButton k_scroll +k_control pushkey ; \ To last move ButtonInfo" To Last Move " 14 PictureButton k_pgdn +k_control pushkey ; \ To next move ButtonInfo" To Next Move " 9 PictureButton k_down +k_control pushkey ; \ ButtonInfo" Minus the Tempo " 10 PictureButton k_up +k_control pushkey ; \ ButtonInfo" More Tempo " 15 PictureButton 'W' +k_control pushkey ; \ ButtonInfo" On/Off the sound" 16 PictureButton 'H' +k_control pushkey ; \ Table of Bests Scores ButtonInfo" Table of Bests Scores" ENDBAR POPUPBAR Solipion-Popup-bar POPUP " " MENUITEM "&New Game " 'N' +k_control pushkey ; MENUITEM "&Automatic Game " 'A' +k_control pushkey ; MENUSEPARATOR MENUITEM "&Open " 'O' +k_control pushkey ; MENUITEM "&Re-open " 'R' +k_control pushkey ; MENUSEPARATOR MENUITEM "&Save " 'E' +k_control pushkey ; MENUITEM "Save &As " 'S' +k_control pushkey ; MENUSEPARATOR MENUITEM "Print &Text" 'T' +k_control pushkey ; MENUITEM "Print &Bitmap" 'B' +k_control pushkey ; MENUSEPARATOR MENUITEM "&Quit" 'Q' +k_control pushkey ; ENDBAR MENUBAR Solipion-Menu-bar POPUP "&Game" MENUITEM "&New \tCtrl+N" 'N' +k_control pushkey ; MENUITEM "&Automatic \tCtrl+A" 'A' +k_control pushkey ; MENUSEPARATOR MENUITEM "&Open... \tCtrl+O" 'O' +k_control pushkey ; MENUITEM "&Re-Open \tCtrl+R" 'R' +k_control pushkey ; MENUSEPARATOR MENUITEM "&Save \tCtrl+E" 'E' +k_control pushkey ; MENUITEM "Save &As... \tCtrl+S" 'S' +k_control pushkey ; MENUSEPARATOR MENUITEM "Print Setup... \tCtrl+Shift+P" 'P' +k_control +k_shift pushkey ; MENUITEM "&Print Text... \tCtrl+P" 'P' +k_control pushkey ; MENUITEM "&Print Bitmap... \tCtrl+B" 'B' +k_control pushkey ; MENUSEPARATOR MENUITEM "Quit \tCtrl+Q" 'Q' +k_control pushkey ; POPUP "&About..." MENUITEM "SoliPion" k_F1 +k_control pushkey ; ENDBAR Index: SOLIPION.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/apps/Solipon2/SOLIPION.F,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** SOLIPION.F 2 Dec 2006 10:17:30 -0000 1.7 --- SOLIPION.F 30 Apr 2008 15:58:00 -0000 1.8 *************** *** 1,15 **** ! \ SOLIPION.F 2.01 ! s" apps\Solipon2" "fpath+ ! needs old\optimize.f needs Resources.f ! only forth also definitions - 1280 value screen-mwidth [...1540 lines suppressed...] --- 1076,1094 ---- ; ! turnkey? [if] + \ NoConsoleIO \ Setup the Console I/O for an application without the console window. + \ NoConsoleInImage \ Tell Imageman that we don't need the w32fconsole.dll. + + \ Create the exe-file + &forthdir count &appdir place + ' solipion turnkey Solipion.exe + + \ add the Application icon to the EXE file + s" src\res\Win32For.ico" s" Solipion.exe" Prepend<home>\ AddAppIcon + + 1 pause-seconds bye + [else] + s" src\res\Win32For.ico" s" Solipion.exe" Prepend<home>\ AddAppIcon + solipion + [then] |
