home *** CD-ROM | disk | FTP | other *** search
/ M.u.C.S. Disc 2000 / MUCS2000.iso / spiele / puzzle / puzzle.4th < prev    next >
Text File  |  1999-02-26  |  9KB  |  337 lines
  1. \
  2.  
  3.               -1 CONSTANT APP IMMEDIATE
  4.              APP [IF] system automark on [THEN]
  5.  
  6. mforth    [ifndef] ARRAY INCLUDE science\fsl_util.seq    [THEN]
  7. mforth    INCLUDE system\file.4th
  8. mforth    XBIOS 0= [IF] INCLUDE system\xbios.4th    [THEN]
  9.  
  10. mforth    INCLUDE xgem\xgem.4th
  11.             gemdefs ALSO
  12.  
  13.             INCLUDE puzzle\puzzle.h
  14.  
  15. APP [IF]
  16. CREATE rscName ," puzzle.rsc"
  17. CREATE picName ," puzzle.pic"
  18. [ELSE]
  19. CREATE rscName ," e:\.\forth\puzzle\puzzle.rsc"
  20. CREATE picName ," e:\.\forth\puzzle\puzzle.pic"
  21. [THEN]
  22.  
  23. CREATE InfoString    32 ALLOT
  24.  
  25. #define ROWS    5
  26. #define COLS    5
  27. #define WIDTH     64
  28.  
  29. 0 VALUE mainWin
  30.           WNAME INFO + MOVER + SMALLER + 
  31.   VALUE WIN_TYPE
  32. 0 VALUE fh
  33.  
  34.  VARIABLE status
  35. 2VARIABLE frei
  36. 2VARIABLE clicked
  37.  VARIABLE richtig
  38.  VARIABLE schwierig
  39.  
  40. MFDB picMFDB
  41. MFDB oriMFDB
  42. MFDB mixMFDB
  43.  
  44. ROWS COLS DOUBLE MATRIX crc{{
  45.  
  46. \ --------------------------------------------------------
  47. : calc_window_size    ( -- x y w h )
  48.     WC_BORDER WIN_TYPE 16 48
  49.     [ ROWS WIDTH q* ] LITERAL
  50.     [ COLS WIDTH q* ] LITERAL gl_hattr w@ + wind_calc ;
  51. \ --------------------------------------------------------    
  52. : change                ( a1 a2 -- )    DUP @ >R >R DUP @ R> ! R> SWAP ! ;
  53. \ --------------------------------------------------------    
  54. : random.RC            ( -- r c )    [ xbios ] 
  55.     random ROWS MOD
  56.     random COLS MOD ;
  57. : rc>xy            ( r c -- x y )            WIDTH WIDTH xy* ;
  58. : rc>wxy            ( x y -- wx wy )        rc>xy mainWin work 2w@ pair+ ;
  59. : xy>rec            ( x y -- x y x' y' )    WIDTH DUP >xyxy ;
  60. \ --------------------------------------------------------
  61. : allocateMFDBs    ( -- flag )
  62.     ROWS COLS WIDTH DUP xy* oriMFDB allocMFDB
  63.     ROWS COLS WIDTH DUP xy* mixMFDB allocMFDB AND
  64.     WIDTH DUP                   picMFDB allocMFDB AND ;
  65. \ --------------------------------------------------------
  66. : fertig                ( -- flag )
  67.     richtig off
  68.     ROWS 0 DO
  69.      COLS 0 DO
  70.       crc{{ J I }} 2@ = IF richtig inc THEN
  71.      LOOP
  72.      LOOP
  73.     richtig @ COLS ROWS q* = 
  74.     C" Richtig: " InfoString strcpy
  75.     richtig @ 0 <# #S #> DROP InfoString strcat 
  76.     mainWin w@ InfoString wind_info ;
  77. \ --------------------------------------------------------
  78. : blackbar            ( x y -- )    1 sf_color
  79.     rc>xy 
  80.     mainWin work 2w@ pair+ 2DUP >R >R
  81.     WIDTH WIDTH >xyxy bar 
  82.     0 sl_color R> R> 2DUP 
  83.     WIDTH WIDTH >xyxy line 
  84.     WIDTH 0 pair+ 2DUP WIDTH NEGATE WIDTH pair+ line ;
  85. \ --------------------------------------------------------
  86. : swapMFDB            ( x y x' y' -- )
  87.     hide_mouse
  88.     rc>wxy xy>rec                    \ Screenkoordinaten
  89.     4dup 4>r                            \ scr 2 scr
  90.     0 0 WIDTH 1- WIDTH 1-        \ Ziel in picMFDB
  91.     scrMFDB picMFDB 3 ro_cpyfm 
  92.     2DUP                        \ source
  93.     rc>wxy xy>rec            \ ... Koordinaten
  94.     4r>                         \ Zielkoordinaten
  95.     scrMFDB scrMFDB 3 ro_cpyfm 
  96.     >R >R                        \ source
  97.     0 0 WIDTH 1- WIDTH 1- R> R>
  98.     rc>wxy xy>rec            \ ... Koordinaten
  99.     picMFDB scrMFDB 3 ro_cpyfm 
  100.     show_mouse ;
  101. \ --------------------------------------------------------
  102. : >original            ( -- )
  103.     hide_mouse
  104.      mainWin work 4w@ 2DUP >R >R
  105.      >xyxy 0 0 R> R> 1 1 pair- 
  106.      scrMFDB oriMFDB 3 ro_cpyfm 
  107.     show_mouse ;
  108. \ --------------------------------------------------------
  109. : original>            ( -- )
  110.     hide_mouse 
  111.      0 0 mainWin work.w 2w@
  112.      mainWin work 4w@ >xyxy
  113.      oriMFDB scrMFDB 3 ro_cpyfm 
  114.     show_mouse ;
  115. \ --------------------------------------------------------
  116. : >picture            ( -- )
  117.     hide_mouse
  118.      mainWin work 4w@ 2DUP >R >R
  119.      >xyxy 0 0 R> R> 1 1 pair- 
  120.      scrMFDB mixMFDB 3 ro_cpyfm 
  121.     show_mouse ;
  122. \ --------------------------------------------------------
  123. : picture>            ( -- )
  124.     hide_mouse 
  125.      0 0 mainWin work.w 2w@
  126.      mainWin work 4w@ >xyxy
  127.      mixMFDB scrMFDB 3 ro_cpyfm 
  128.     show_mouse ;
  129. \ --------------------------------------------------------
  130. : mouse2rc             ( w h mx my ox oy -- r c ) 
  131.     pair-                \ Koordinaten normalisieren 
  132.     ROT  q/ >R          \ y/h 
  133.     SWAP q/ R> ;         \ x/w 
  134. \ --------------------------------------------------------
  135. : ?frei                ( -- flag )     clicked 2@ pair+ frei 2@ D= ;
  136. : feldfrei            ( -- flag )
  137.     FALSE
  138.     -1 0 ?frei IF 0= EXIT THEN 
  139.      1 0 ?frei IF 0= EXIT THEN 
  140.     0 -1 ?frei IF 0= EXIT THEN 
  141.      0 1 ?frei IF 0=          THEN ;
  142. \ --------------------------------------------------------
  143. : raster                ( -- )
  144.     schwierig @ IF EXIT THEN
  145.     1 sl_color
  146.     1 sl_width
  147.     1 sl_type
  148.     ROWS 1 DO
  149.      mainWin work  2w@ I WIDTH q* + OVER
  150.      mainWin work.w w@ + OVER line
  151.     LOOP
  152.     COLS 1 DO
  153.      mainWin work.x w@ WIDTH I q* +
  154.      mainWin work.y w@ 2DUP
  155.      mainWin work.h w@ + line
  156.     LOOP ;
  157. \ --------------------------------------------------------
  158. : mischen            ( -- )
  159.     ROWS 1- COLS 1- frei 2!
  160.  
  161.     0 0 
  162.     ROWS 0 DO
  163.      COLS 0 DO
  164.       2DUP 2DUP crc{{ J I }} 4w!
  165.       1+
  166.      LOOP
  167.      DROP 1+ 0
  168.     LOOP 2DROP
  169.  
  170.     ROWS COLS q* 2* 0 DO
  171.      random.RC frei 2@ 2OVER D= 
  172.      random.RC frei 2@ 2OVER D= OR
  173.      IF
  174.       4drop
  175.      ELSE
  176.       crc{{ 4 PICK 4 PICK }} >R
  177.       crc{{ 2pick  2pick  }} R> change
  178.       swapMFDB 
  179.      THEN
  180.     LOOP 
  181.  
  182.     frei 2@ blackbar
  183.     raster
  184.     >picture ;
  185. \ --------------------------------------------------------
  186. : CreatePicture        ( -- )    
  187.     30 0 DO                [ xbios ]
  188.      random [ ROWS WIDTH q* ] LITERAL MOD
  189.      random [ ROWS WIDTH q* ] LITERAL MOD
  190.      mainWin work 4w@ >xyxy 1 s_clip
  191.      mainWin work 2w@ pair+
  192.      I sf_color
  193.      random WIDTH DUP 2/ + MOD 10 MAX circle
  194.     LOOP ;
  195. \ --------------------------------------------------------
  196. : LoadPuzzlePic    ( -- flag )
  197.     picName COUNT R/O OPEN-FILE 0=
  198.     IF
  199.      TO fh
  200.      oriMFDB @ 20 fh READ-FILE 2DROP
  201.      oriMFDB @ [ 320 320 * ] LITERAL fh READ-FILE 2DROP
  202.      fh CLOSE-FILE DROP
  203.      original>        \ Bild zeigen
  204.      >picture        \ zum Zerlegen
  205.      TRUE
  206.     ELSE 
  207.      2DROP
  208.      FALSE
  209.     THEN ;
  210. \ --------------------------------------------------------
  211. : LoadPicture        ( -- )
  212.     LoadPuzzlePic
  213.     IF
  214.      original>
  215.     ELSE
  216.      CreatePicture
  217.      >original
  218.     THEN
  219.     raster
  220.     mischen
  221.     fertig DROP
  222.     1 status ! 
  223.     WRedraw ;
  224. \ --------------------------------------------------------
  225. : DrawPicture    ( -- )    picture> raster ;
  226. \ --------------------------------------------------------
  227. : Click        ( -- )
  228.     WIDTH WIDTH mousexy mainWin work 2w@ mouse2rc clicked 2!
  229.     feldfrei
  230.     IF
  231.     frei 2@ clicked 2@ swapMFDB
  232.     
  233.     crc{{ frei 2@     }}
  234.     crc{{ clicked 2@ }} change
  235.     
  236.     clicked 2@ frei 2! 
  237.     
  238.     fertig
  239.     IF
  240.       4 status !
  241.      ELSE
  242.      raster >picture
  243.      THEN
  244.           
  245.     THEN ;
  246. \ --------------------------------------------------------
  247. : Ende                ( -- )    RSC_QUIT Alert 1 = IF Die THEN ;
  248. \ --------------------------------------------------------
  249. : NewGame            ( -- )
  250.     NEWGAME Alert 1 =
  251.     IF
  252.      0 sf_color        [ HIDDEN ]
  253.      mainWin work 4w@ 
  254.      4dup >xyxy 1 s_clip clr_area
  255.      LoadPicture
  256.     ELSE
  257.      Ende
  258.     THEN ;
  259. \ --------------------------------------------------------
  260. : juhuu        ( -- )    DUWIN Alert DROP status off ;    
  261. \ --------------------------------------------------------
  262. : Draw        ( -- )
  263.     status @
  264.     CASE
  265.      0 OF LoadPicture    ENDOF
  266.      1 OF DrawPicture ENDOF
  267.      3 OF original> 2000 0 evnt_timer 1 status ! WRedraw ENDOF
  268.      4 OF juhuu            ENDOF
  269.     ENDCASE ;
  270. \ --------------------------------------------------------
  271. : help        ( -- )    3 status ! WRedraw ;
  272. \ --------------------------------------------------------
  273. : PrgInfo    ( -- )
  274.     BG_INFO DIAL_CT WI_DEFDIAL 0 CreateDial
  275.     IF
  276.      C"  Programinfo Puzzle " NULL ROT OpenWindow
  277.     THEN ;
  278. \ --------------------------------------------------------
  279. : OpenMainWindow    ( -- )
  280.     calc_window_size                        \ max. Size
  281.     2DUP                                         \ min w,h
  282.     [ WI_DATA WI_FULLED OR WI_CENTER OR ] LITERAL
  283.     WIN_TYPE
  284.     CreateWindow
  285.     IF
  286.       TO mainWin
  287.       status off
  288.       MAINMENU 1 mainWin IsWindowMenu
  289.  
  290.       0           ENDE $1011 mainWin WMenuAction: Ende
  291.       0 INFORMATION    -1 mainWin WMenuAction: PrgInfo
  292.       0 HELP                 -1 mainWin WMenuAction: help
  293.       0 CVH                 -1 mainWin WMenuAction: NewGame
  294.       
  295.       C"  Puzzle " NULL mainWin OpenWindow
  296.       ['] noop  mainWin *move !
  297.       ['] Draw  mainWin *draw !
  298.       ['] Click mainWin *click !
  299.       ['] noop    mainWin *close !
  300.       \ ['] noop     mainWin *key !
  301.      THEN ;
  302.  
  303. : main ( -- )
  304.    rscName -1 OpenApp           \ No Global Menu
  305.    IF
  306.     InitWindows         \ Initialize windows
  307.     RC OpenVWork        \ Needs a VDI-Workstation
  308.  
  309.     [ MU_KEYBD MU_BUTTON OR MU_MESAG OR ] LITERAL
  310.     1 1 1  WatchEvents  \ Watch these events
  311.     500 0 WatchTimer: noop
  312.  
  313.      allocateMFDBs
  314.      IF
  315.       OpenMainWindow
  316.      HandleEvents
  317.  
  318.       oriMFDB freeMFDB
  319.       picMFDB freeMFDB
  320.       mixMFDB freeMFDB
  321.      THEN
  322.      
  323.     CloseVWork
  324.     KillWindows
  325.     CloseApp
  326.    THEN
  327.  
  328.    APP [IF] return         \ Leave programm
  329.    [ system ]
  330.    mark                    \ compile marked words
  331.    [THEN] ;
  332.  
  333.  
  334. APP [IF]
  335.     system make puzzle.app
  336. [THEN]
  337.