|
|
|---|
|
|
|
|
|
|
|
|
|
|
|
|
|
XYamb.f90 Source |
Build as a Windows application. Link with XFT.lib.
!=======================================================================
! ___________
! \\//-----------
! )( //== //
! //\\ // //
!=======================================================================
! EXTENDED FORTRAN TYPES LIBRARY SAMPLES
!=======================================================================
! _Yamb.f90 - Main application module for XYamb sample.
!
! XYamb is a simple game written in XFT. The Yamb game is slightly
! modified "Yacht" or "Yachtzee". The sample demonstrates:
! * usage of SDI architecture with menu, view window, toolbar and status bar
! * drawing on application windows using XFTGDI routines
! * usage of registry routines to store last user name and high score list
!
! 2005. Jugoslav Dujic (jdujic@uns.ns.ac.yu)
!
! You are free to use the code for both commercial and non-commercial
! use. The code is provided as-is without warranties. You are free to
! distribute and modify this source code provided that the list of
! original author(s) remains untouched and your revisions are indicated
! as such. Contributions are welcome.
!=======================================================================
!XChild_OnPaint
!XFrame_OnGetMMInfo
!XChild_OnLButtonUp
!OnNewRoll
!OnRoll
!OnTopTen
!OnAnnounce
!OnUndo
!OnNewGame
!OnExit
!DrawTable
!CalcResult
!GameOver
!ResetState
!XInit
!=======================================================
MODULE XYamb
USE XFT
USE DFWIN
IMPLICIT NONE
TYPE(X_WINDOW):: xChild !View window
TYPE(X_MENU):: xMenu !Main menu
TYPE(X_TOOLBAR):: xTb !Toolbar
INTEGER, PARAMETER:: COMPLETE = 0, & !Field is completed
LOCKED = 1, & !Field is free, but disabled
FREE = 2 !Field is free, but enabled
INTEGER, PARAMETER:: ACT_WRITE = 1, & !Last action is "enter the result"
ACT_ANNOUNCE = 2, & !Last action is "announce"
ACT_ANNOUNCE_SEL = 3 !Last action is "select announced field"
INTEGER, PARAMETER:: nColumns = 4
INTEGER:: iResult(15, nColumns), & !Result of each field (including the intermediates)
iState(15, nColumns), & !State of each field in the table
nLastAction = 0, & !Last action to be undid
nLastCol = 0, & !Last filled column
nLastRow = 0, & !Last filled row
iDice(6), & !Numbers on each dice
nRolls = 1, & !Current roll
iTotal !Total game result
CHARACTER(100) sPlayerName !Name of actual player
CHARACTER(*), PARAMETER:: APP_REGKEY = "Software\XFT\Yamb\2.0"
LOGICAL:: bKeep(6) = .FALSE., & !Selected dice
bAnnounce = .FALSE. !TRUE if "Announce" is selected but the field is not chosen yet
CHARACTER(20):: sTopTenName(10) !Names of top 10 players
INTEGER:: iTopTenResult(10) !Results of top 10 players
INTEGER:: IDC_STATUS
!=======================================================
CONTAINS
!=======================================================
!PURPOSE: Initialization function called by XFT library on app start.
INTEGER FUNCTION XInit(szCmdLine, nCmdShow)
!DEC$ATTRIBUTES DEFAULT, DECORATE, ALIAS: 'XINIT':: XInit
USE XFT
USE XFTMENU
USE XFTCTRL
USE DFWIN
!USE COMCTL32
IMPLICIT NONE
CHARACTER*(*) szCmdLine
INTEGER, INTENT(IN):: nCmdShow
TYPE(X_WINDOW):: xWnd
INTEGER:: iSt, iParts(2) = (/80, -1/), iX1, iY1, iX2, iY2, iWidth, iHeight, &
hKey, iSize, iType, tbHeight, sbHeight
LOGICAL:: bSt
TYPE(T_RECT):: Rect
TYPE(X_WINDOW):: Dlg
TYPE(X_TBBUTTON):: xButtons(5)
TYPE(X_BITMAP):: xBmp
INCLUDE 'Resource.fd'
!Loading menu resource & attaching it to the frame
xMenu = XLoadMenu(IDR_MENU_YAMB)
!Creation of App & frame window
iSt = XCreateSDIApp(xMenu, "XYamb", IDI_ICON_YAMB)
iSt = XSetWindowMenu(XW_FRAME, xMenu)
!Moving frame to screen center
iSt = SystemParametersInfo(SPI_GETWORKAREA, 0, LOC(Rect), 0)
iX1 = Rect%Right/2
iY1 = Rect%Bottom/2
iSt = XSetWindowPos(XW_FRAME, iX1-200, iY1-300, 400, 600)
iSt = XGetClientRect(XW_FRAME, iWidth, iHeight)
!Creation of toolbar
iSt = XCreateToolbar(XW_FRAME, xTb, IDR_TOOLBAR2, WS_BORDER.OR.TBSTYLE_FLAT.OR.TBSTYLE_TOOLTIPS, 16, 16, 16, 15)
bSt = XCreateBitmap(xBmp, IDR_TOOLBAR2, LR_LOADMAP3DCOLORS)
iSt = XToolbarSet(xTb, IDR_TOOLBAR2, xBmp%hBmp, CTL_BITMAP)
xButtons(1) = X_TBBUTTON(ID_ACTION_ROLL, TBSTATE_ENABLED, TBSTYLE_BUTTON, 1, 0)
xButtons(2) = X_TBBUTTON(ID_ACTION_NEWROLL, TBSTATE_ENABLED, TBSTYLE_BUTTON, 2, 0)
xButtons(3) = X_TBBUTTON(0, 0, TBSTYLE_SEP, 0, 0)
xButtons(4) = X_TBBUTTON(ID_ACTION_ANNOUNCE, TBSTATE_ENABLED, TBSTYLE_BUTTON, 3, 0)
xButtons(5) = X_TBBUTTON(ID_ACTION_UNDO, TBSTATE_ENABLED, TBSTYLE_BUTTON, 4, 0)
iSt = XToolbarAddButtons(xTb, xButtons(1:5), 0)
IDC_STATUS = XCtlCreate(XW_FRAME, 2, XCTL_STATUS, 0)
iSt = XCtlSet(XW_FRAME, IDC_STATUS, iParts, CTL_RECTS)
iSt = XCtlSet(XW_FRAME, IDC_STATUS, .TRUE., CTL_VISIBLE)
iSt = XCtlGetPos(XW_FRAME, IDC_STATUS, iHeight=sbHeight)
iSt = XToolbarGetPos(xTb, iHeight=tbHeight)
iSt = XCreateWindow(xChild, XW_FRAME, WS_CHILD, ""C, XS_EX_DBLBUFFERED, 0, tbHeight, iWidth, iHeight-tbHeight-sbHeight)
iSt = XShowWindow(xChild, SW_SHOW)
bSt = XSetHandler(xChild, WM_PAINT, XChild_OnPaint)
bSt = XSetHandler(xChild, WM_LBUTTONUP, XChild_OnLButtonUp)
bSt = XSetHandler(XW_FRAME, WM_GETMINMAXINFO, XFrame_OnGetMMInfo)
bSt = XSetCommand(XW_FRAME, ID_GAME_NEW, OnNewGame)
bSt = XSetCommand(XW_FRAME, ID_GAME_TOPTEN, OnTopTen)
bSt = XSetCommand(XW_FRAME, ID_GAME_EXIT, OnExit)
bSt = XSetCommand(XW_FRAME, ID_ACTION_ROLL, OnRoll)
bSt = XSetCommand(XW_FRAME, ID_ACTION_NEWROLL, OnNewRoll)
bSt = XSetCommand(XW_FRAME, ID_ACTION_ANNOUNCE, OnAnnounce)
bSt = XSetCommand(XW_FRAME, ID_ACTION_UNDO, OnUndo)
hKey = XRegOpen(HKEY_LOCAL_MACHINE, APP_REGKEY)
iSt = XRegRead(hKey, "Player", sPlayerName)
iSt = XRegRead(hKey, "TopTenResult", LOC(iTopTenResult), SIZEOF(iTopTenResult))
iSt = XRegRead(hKey, "TopTenName", LOC(sTopTenName), SIZEOF(sTopTenName))
iSt = XLoadDialog(IDD_NAME, Dlg, XW_FRAME)
iSt = XCtlSet(Dlg, IDC_EDIT_NAME, sPlayerName, CTL_STATE)
iSt = XModalDialog(Dlg)
iSt = XCtlGet(Dlg, IDC_EDIT_NAME, sPlayerName, CTL_STATE)
CALL XDestroyDialog(Dlg)
iSt = XCtlSet(XW_FRAME, IDC_STATUS, sPlayerName, 1)
iSt = XRegWrite(hKey, "Player", sPlayerName)
CALL XRegClose(hKey)
iDice = 0
XInit = 1
CALL OnNewGame(XW_FRAME, 0, 0)
END FUNCTION XInit
!=======================================================
!PURPOSE: handler for WM_GETMINMAXINFO message. Prevents the
!frame from resizing by setting nMinSize and nMaxSize to (400, 600)
INTEGER FUNCTION XFrame_OnGetMMInfo(xWnd, xSizeMax, xMaxPos, xMinSize, xMaxSize)
TYPE(X_WINDOW), INTENT(IN):: xWnd
TYPE(X_POINT), INTENT(INOUT):: xSizeMax
TYPE(X_POINT), INTENT(INOUT):: xMaxPos
TYPE(X_POINT), INTENT(INOUT):: xMinSize !Minimal allowed size
TYPE(X_POINT), INTENT(INOUT):: xMaxSize !Maximal allowed size
xMinSize = X_POINT(400, 600)
xMaxSize = X_POINT(400, 600)
XFrame_OnGetMMInfo = 0
END FUNCTION XFrame_OnGetMMInfo
!=======================================================
!PURPOSE: handler for WM_PAINT message. Draws the dice and
!the table.
INTEGER FUNCTION XChild_OnPaint(xWnd, xDC, iX1, iY1, iX2, iY2)
TYPE(X_WINDOW):: xWnd !Window ( = xChild)
TYPE(X_DC):: xDC !Window's DC
INTEGER, INTENT(IN):: iX1, iY1, iX2, iY2 !Dimensions of update rectangle
INTEGER:: iSt, i, nColor, iX, iY, n
INTEGER, PARAMETER:: iSpot(9,6) = (/0, 0, 0, 0, 1, 0, 0, 0, 0, & !Spots on dice
1, 0, 0, 0, 0, 0, 0, 0, 1, &
0, 0, 1, 0, 1, 0, 1, 0, 0, &
1, 0, 1, 0, 0, 0, 1, 0, 1, &
1, 0, 1, 0, 1, 0, 1, 0, 1, &
1, 0, 1, 1, 0, 1, 1, 0, 1/)
!ClearScreen
CALL XSetBrush(xDC, XCOLOR_GREEN)
CALL XSetPen(xDC, XCOLOR_GREEN)
iSt = XRectangle(xDC, 0, 0, xDC%xView%iXExt, xDC%xView%iYExt)
XChild_OnPaint = 0
!Don't draw if the game is not started yet
IF (iDice(1).EQ.0) RETURN
!Drawing dice
DO i = 1, 6
IF (bKeep(i)) THEN
nColor = XCOLOR_LTCYAN
ELSE
nColor = XCOLOR_YELLOW
END IF
iSt = XRectangle(xDC, 20, 80*i-60, 80, 80*i, &
X_PEN(PS_SOLID, 0, nColor), &
X_BRUSH(BS_SOLID, nColor, 0))
CALL XSetBrush(xDC, XCOLOR_GREEN)
CALL XSetPen(xDC, XCOLOR_GREEN)
iSt = XRectangle(xDC, 20, 80*I-60, 30, 80*I-50)
iSt = XRectangle(xDC, 70, 80*I-60, 80, 80*I-50)
iSt = XRectangle(xDC, 20, 80*I-10, 30, 80*I)
iSt = XRectangle(xDC, 70, 80*I-10, 80, 80*I)
CALL XSetBrush(xDC, nColor)
CALL XSetPen(xDC, nColor)
iSt = XEllipse(xDC, 20, 80*I-60, 40, 80*I-40)
iSt = XEllipse(xDC, 60, 80*I-60, 80, 80*I-40)
iSt = XEllipse(xDC, 20, 80*I-20, 40, 80*I)
iSt = XEllipse(xDC, 60, 80*I-20, 80, 80*I)
CALL XSetBrush(xDC, XCOLOR_BLACK)
!Draw spots
DO ix = 1, 3
DO iy = 1, 3
n = ix+3*(iy-1)
IF(iSpot(n, iDice(i)).eq.1) THEN
iSt = XEllipse(xDC, 16+15*ix, 80*i-64+15*iy, 24+15*ix, 80*i-60+15*iy+4)
END IF
END DO
END DO
END DO
CALL DrawTable(xDC)
END FUNCTION XChild_OnPaint
!=======================================================
!PURPOSE: handler for WM_LBUTTONUP message
INTEGER FUNCTION XChild_OnLButtonUp(xWnd, iX, iY, Msg, iKeyState)
TYPE(X_WINDOW):: xWnd !Window ( = xChild)
INTEGER:: iX, iY, Msg, iKeyState !Click coordinates and state of keys
INTEGER:: iSt, i, j, k, m, iX1, iY1, iX2, iY2, iXStep, iYStep
INCLUDE "Resource.fd"
!If one of dice is hit, toggle its keep state
DO i = 1, 6
IF(iY.GE.80*I-60 .AND. iY.LE.80*I .AND. iX.GE.20 .AND. (iX.LE.80)) &
bKeep(i) = .NOT.bKeep(i)
END DO
iXStep = 50
iYStep = 30
XChild_OnLButtonUp = 0
!Checking the table for click
DO j = 1, nColumns
DO k = 1, 14
ix1 = 100+j*(iXStep)
ix2 = ix1+45
iy1 = k*(iYStep)
iy2 = iy1+25
IF(iY.GE.iy1 .AND. iY.LE.iy2 .AND. iX.GE.ix1 .AND.iX.LE.ix2) THEN
IF(iState(k, j).eq.FREE) THEN
!The clicked field (k, j) is found
IF (bAnnounce) THEN
bAnnounce = .FALSE.
!Enable roll & disable re-announce
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
!Save Undo information
nLastCol = j
nLastRow = k
nLastAction = ACT_ANNOUNCE_SEL
iSt = XMenuSet(xMenu, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
!Lock all other fields for writing
DO m = 1, 14
IF (iState(m, 4).NE.COMPLETE .AND. m.NE.k) iState(m, 4) = LOCKED
END DO
iSt = XCtlSet(XW_FRAME, IDC_STATUS, "Roll the dice.", 2)
ELSE
!Save Undo information
nLastCol = j
nLastRow = k
nLastAction = ACT_WRITE
!Enable undo except if last roll with announcement
IF (.NOT.(j.EQ.4 .AND. nRolls.EQ.3)) THEN
iSt = XMenuSet(xMenu, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
END IF
CALL CalcResult(k, j)
!Lock entire table - no entry can be made until undo or new roll
WHERE (iState.EQ.FREE)
iState = LOCKED
END WHERE
END IF
CALL XUpdateWindow(xWnd)
RETURN
ELSE
RETURN
END IF
END IF
END DO
END DO
CALL XUpdateWindow(xWnd)
END FUNCTION XChild_OnLButtonUp
!=======================================================
!PURPOSE: Handler for Action/New Roll menu.
SUBROUTINE OnNewRoll(xWnd, ID, nCode)
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
INTEGER:: iSt
INCLUDE "Resource.fd"
IF (nCode.EQ.0) THEN
iSt = XMenuSet(xMenu, ID_ACTION_NEWROLL, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_NEWROLL, .FALSE., XC_ENABLE)
!Reset keep status and number of rolls
bKeep = .FALSE.
nRolls = 0
!Reset the table to normal state
CALL ResetState
CALL OnRoll(xWnd, ID, nCode)
END IF
END SUBROUTINE OnNewRoll
!=======================================================
!PURPOSE: Handler for Action/Roll menu.
SUBROUTINE OnRoll(xWnd, ID, nCode)
USE MSFLIB
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
INTEGER:: iSt, i
REAL:: fRnd
CHARACTER(30):: sMessage
INCLUDE "Resource.fd"
IF (nCode.EQ.0) THEN
nRolls = nRolls+1
IF (nRolls.EQ.3) THEN
sMessage = "Enter the result."
ELSE
WRITE(sMessage, "('Roll ', i1, a1)") nRolls
END IF
!iSt = XSendMessage(xStatus, SB_SETTEXT, 1, LOC(sMessage))
iSt = XCtlSet(XW_FRAME, IDC_STATUS, sMessage, 2)
!Enable announce if 1st roll; disable roll if 3rd roll
iSt = XMenuSet(xMenu, ID_ACTION_ANNOUNCE, nRolls.EQ.1, XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, nRolls.LT.3, XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ANNOUNCE, nRolls.EQ.1, XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, nRolls.LT.3, XC_ENABLE)
IF (nRolls.EQ.1) THEN
!If only "announced" column is left, disable "Roll" item
IF (ALL(iState(1:14, 1:3).EQ.COMPLETE)) iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
END IF
iSt = XMenuSet(xMenu, ID_ACTION_UNDO, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_UNDO, .FALSE., XC_ENABLE)
!Assign random numbers to dice
CALL SEED(RND$TIMESEED)
DO i = 1, 6
IF (.NOT.bKeep(i)) THEN
CALL RANDOM(fRnd)
iDice(i) = INT(6*fRnd)+1
END IF
END DO
CALL XUpdateWindow(xChild)
END IF
END SUBROUTINE OnRoll
!=======================================================
!PURPOSE: Callback for Game/Top ten menu item. Displays the "Top ten"
!Dialog
SUBROUTINE OnTopTen(xWnd, ID, nCode)
USE XSTRINGS
USE XFTCTRL
!USE XFLOGM2
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
TYPE(X_WINDOW):: Dlg
!TYPE(DIALOG):: Dlg
CHARACTER*5:: sTemp
INTEGER:: iSt, i
INCLUDE "Resource.fd"
iSt = XLoadDialog(IDD_TOPTEN, Dlg, XW_FRAME)
DO i = 1, 10
iSt = XCtlSet(Dlg, IDC_IME1+i-1, sTopTenName(i), CTL_TITLE)
WRITE(sTemp, '(i4)') iTopTenResult(i)
iSt = XCtlSet(Dlg, IDC_REZ1+i-1, sTemp, CTL_TITLE)
IF (iTopTenResult(i).EQ.iTotal .AND. STRCMP(sTopTenName(i), sPlayerName)) THEN
iSt = XCtlSet(Dlg, IDC_IME1+i-1, #FF, CTL_COLOR)
END IF
END DO
iSt = XModalDialog(Dlg)
CALL XDestroyDialog(Dlg)
!xDlg = XLoadDialog(IDD_TOPTEN)
!DO i = 1, 10
! iSt = XCtlSet(xDlg, IDC_IME1+i-1, sTopTenName(i), CTL_TITLE)
! WRITE(sTemp, '(i4)') iTopTenResult(i)
! iSt = XCtlSet(xDlg, IDC_REZ1+i-1, sTemp, CTL_TITLE)
! IF (iTopTenResult(i).EQ.iTotal .AND. sTopTenName(i).EQ.sPlayerName) THEN
!! iSt = XCtlSet(xDlg, IDC_IME1+i-1, #FF, CTL_COLOR)
! END IF
!END DO
!iSt = XModalDialog(xDlg, xChild%hWnd)
!CALL xDlgUnInit(xDlg)
END SUBROUTINE OnTopTen
!=======================================================
!PURPOSE: Callback for Announce/Top Ten menu item.
SUBROUTINE OnAnnounce(xWnd, ID, nCode)
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
INTEGER:: iSt, j, k
INCLUDE "Resource.fd"
IF (nCode.EQ.0) THEN
!Lock the entire table except "announce" column
DO j = 1, 14
IF (iState(j, 4).eq.LOCKED) iState(j, 4) = FREE
DO k = 1, 3
IF(iState(j, k).eq.FREE) iState(j, k) = LOCKED
END DO
END DO
!Save undo information
nLastAction = ACT_ANNOUNCE
bAnnounce = .TRUE.
!Disable "Announce" & "Roll" (until a field is selected in OnLButtonUp).
!Enable "Undo".
iSt = XMenuSet(xMenu, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_UNDO, .TRUE., XC_ENABLE)
iSt = XCtlSet(XW_FRAME, IDC_STATUS, "Select the field to announce.", 2)
CALL XUpdateWindow(xChild)
END IF
END SUBROUTINE OnAnnounce
!=======================================================
!PURPOSE: Handler for Action/Undo menu item. Restores the previous
!state (applicable in case of misclicking a field or changing mind
!when making an announcement)
SUBROUTINE OnUndo(xWnd, ID, nCode)
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
CHARACTER(40):: sMessage
INTEGER:: iSt, j, k
INCLUDE "Resource.fd"
IF (nCode.EQ.0) THEN
SELECT CASE (nLastAction)
CASE(ACT_ANNOUNCE)
!Last action is Action/Announce. Reset the table into
!normal state, re-enable "Roll" and "Announce" menu items.
bAnnounce = .FALSE.
iSt = XCtlGet(XW_FRAME, IDC_STATUS, sMessage, 2)
CALL ResetState()
iSt = XCtlSet(XW_FRAME, IDC_STATUS, sMessage, 2)
iSt = XMenuSet(xMenu, ID_ACTION_ANNOUNCE, .TRUE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ANNOUNCE, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
CASE(ACT_ANNOUNCE_SEL)
!Last action is selection of announce field. Allow only
!to change selection, not to get back to another column.
!Free selected field & unlock "Announced" column
iState(nLastRow, nLastCol) = FREE
DO j = 1, 14
IF (iState(j, 4).EQ.LOCKED) iState(j, 4) = FREE
END DO
!Disable roll & go back to announcement-selection mode
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
bAnnounce = .TRUE.
iSt = XCtlSet(XW_FRAME, IDC_STATUS, "Select the field to announce.", 2)
CASE(ACT_WRITE)
!Last action is writing down the result.
iSt = XCtlGet(XW_FRAME, IDC_STATUS, sMessage, 2)
IF (nLastCol.NE.4) THEN
!If in first three columns, free the clicked field
!and reset the table.
iState(nLastRow, nLastCol) = FREE
iResult(nLastRow, nLastCol) = 0
CALL CalcResult(0, 0)
CALL ResetState()
ELSE IF (nLastCol.EQ.4 .AND. nRolls.LT.3) THEN
!If in "Announced" column, free only that field, and recalculate
!the result
iState(nLastRow, nLastCol) = FREE
iResult(nLastRow, nLastCol) = 0
CALL CalcResult(0, 0)
END IF
IF (nRolls.LT.3) THEN
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .TRUE., XC_ENABLE)
END IF
!Disable new roll until the result is written down (OnLButtonUp)
iSt = XCtlSet(XW_FRAME, IDC_STATUS, sMessage, 2)
iSt = XMenuSet(xMenu, ID_ACTION_NEWROLL, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_NEWROLL, .FALSE., XC_ENABLE)
END SELECT
iSt = XMenuSet(xMenu, ID_ACTION_UNDO, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_UNDO, .FALSE., XC_ENABLE)
CALL XUpdateWindow(xChild)
END IF
END SUBROUTINE OnUndo
!=======================================================
!PURPOSE: Handler for Game/New menu item
SUBROUTINE OnNewGame(xWnd, ID, nCode)
TYPE(X_WINDOW):: xWnd
INTEGER, INTENT(IN):: ID, nCode
INTEGER:: iSt, nFiles
IF (nCode.EQ.0) THEN
!Free entire table
iState = LOCKED
iState(1, 1) = FREE
iState(14, 3) = FREE
iState(:, 2) = FREE
iState(7, :) = COMPLETE
iState(10, :) = COMPLETE
iState(15, :) = COMPLETE
iResult = 0
iResult(7, :) = 0
iResult(10, :) = 0
iResult(15, :) = 0
iTotal = 0
CALL OnNewRoll(xWnd, ID, nCode)
END IF
END SUBROUTINE OnNewGame
!=======================================================
!PURPOSE: Handler for exit menu item
SUBROUTINE OnExit(xWnd, ID, nCode)
TYPE(X_WINDOW):: xWnd
INTEGER:: ID, nCode
INTEGER:: iSt
iSt = XSendMessage(XW_FRAME, WM_CLOSE, 0, 0)
END SUBROUTINE OnExit
!=======================================================
!PURPOSE: Draws the table on xDC. Called from OnPaint callback.
SUBROUTINE DrawTable(xDC)
TYPE(X_DC):: xDC
!Column titles (arrows in "Symbol" font)
INTEGER, PARAMETER:: sColTitle(8) = (/175, 171, 173, 65, 65, 65, 65, 65/)
CHARACTER(15), PARAMETER:: sGames = '123456S+-SSFPYS'
CHARACTER(4):: sNum
INTEGER:: iSt, iXStep, iYStep, j, k, iLength, iX1, iY1, iX2, iY2, nColor1, nColor2, nColorText
iXStep = 50
iYStep = 30
DO k = 1, 15
IF (k.NE.7 .AND. k.NE.10 .AND. k.NE.15) THEN
iSt = XSetFont(xDC, "Arial"C, 12)
ELSE
iSt = XSetFont(xDC, "Symbol"C, 12)
END IF
iSt = XTextOut(xDC, 140, k*30+5, sGames(k:k), XCOLOR_LTGRAY)
END DO
DO j = 1, nColumns
iSt = XSetFont(xDC, "Symbol"C, 12)
iSt = XTextOut(xDC, 100+j*iXStep+iXStep/2-3, 5, CHAR(sColTitle(j)), XCOLOR_LTGRAY)
iSt = XSetFont(xDC, "Arial"C, 12)
DO k = 1, 15
ix1 = 100+j*(iXStep)
ix2 = ix1+45
iy1 = k*(iYStep)
iy2 = iy1+25
SELECT CASE (iState(k, j))
CASE(COMPLETE)
nColor1 = XCOLOR_GREEN
nColor2 = XCOLOR_BLACK
nColorText = XCOLOR_LTGRAY
CASE(LOCKED)
nColor1 = XCOLOR_LTGRAY
nColor2 = XCOLOR_GRAY
nColorText = XCOLOR_GRAY
CASE(FREE)
nColor1 = XCOLOR_WHITE
nColor2 = XCOLOR_BLACK
nColorText = XCOLOR_BLACK
END SELECT
IF (k.NE.7 .AND. k.NE.10 .AND. k.NE.15) THEN
CALL XSetBrush(xDC, nColor1)
CALL XSetPen(xDC, nColor2)
iSt = XRectangle(xDC, ix1, iy1, ix2, iy2)
iSt = XRectangle(xDC, ix1+1, iy1+1, ix2-1, iy2-1)
CALL XSetPen(xDC, XCOLOR_LTGRAY)
CALL XMoveTo(xDC, ix1, iy2)
iSt = XLineTo(xDC, ix2, iy2)
iSt = XLineTo(xDC, ix2, iy1)
CALL XMoveTo(xDC, ix1+1, iy2-1)
iSt = XLineTo(xDC, ix2-1, iy2-1)
iSt = XLineTo(xDC, ix2-1, iy1+1)
END IF
IF((iState(k, j).eq.COMPLETE)) THEN
WRITE(sNum, "(i4)") iResult(k, j)
CALL XGetTextExtent(xDC, sNum, iLength, iSt)
iSt = XTextOut(xDC, ix2-3-iLength, iy1+4, sNum, nColorText)
END IF
END DO
END DO
ix1 = 100+4*iXStep
ix2 = ix1+45
iy1 = 16*iYStep
iy2 = iy1+25
CALL XSetBrush(xDC, XCOLOR_GREEN)
CALL XSetPen(xDC, XCOLOR_BLACK)
iSt = XRectangle(xDC, ix1, iy1, ix2, iy2)
CALL XSetPen(xDC, XCOLOR_LTGRAY)
CALL XMoveTo(xDC, ix1, iy2)
iSt = XLineTo(xDC, ix2, iy2)
iSt = XLineTo(xDC, ix2, iy1)
CALL XMoveTo(xDC, ix1+1, iy2-1)
iSt = XLineTo(xDC, ix2-1, iy2-1)
iSt = XLineTo(xDC, ix2-1, iy1+1)
!Total result
WRITE(sNum, "(i4)") iTotal
CALL XGetTextExtent(xDC, sNum, iLength, iSt)
iSt = XTextOut(xDC, ix2-3-iLength, iy1+4, sNum, nColor2)
END SUBROUTINE DrawTable
!=======================================================
!PURPOSE: Calculates the score in field (k, j), partial scores and
!total scores on the basis of state of the dice. Called from OnLButtonUp
!(and Undo, when undoing state after LButtonUp)
SUBROUTINE CalcResult(k, j)
USE MSFWIN
INTEGER, INTENT(IN):: k, j
LOGICAL:: b2345
INTEGER:: iSt, hKey, nMin, nMax, n, nZeros, iSuma1, iSuma2, iTemp, iRez
INTEGER:: iAux(6)
INCLUDE "Resource.fd"
iRez = 0
SELECT CASE(k)
CASE(1:6)
!First six column
iRez = COUNT(iDice.eq.k)*k
CASE(8)
!Maximum
nmin = MINVAL(iDice) !Die with min. value
iRez = SUM(iDice)-nmin
CASE(9)
!Min
nMax = MAXVAL(iDice) !Die with max. value
iRez = SUM(iDice)-nMax
CASE(11)
!Straight
b2345 = .TRUE.
!Check if there's at least one 2, 3, 4 & 5 in dice set
DO n = 2, 5
b2345 = b2345.AND.(ANY((iDice).eq.n))
END DO
!If it is, and there's at least one 1 or 6, set the score according to roll
IF(b2345.AND.(ANY(iDice.eq.1).OR.ANY(iDice.eq.6))) THEN
IF(nRolls.eq.1)THEN
iRez = 66
ELSE IF(nRolls.eq.2) THEN
iRez = 56
ELSE
iRez = 46
END IF
END IF
CASE (12:14)
!Full, Poker, Yamb
DO n = 1, 6
iAux(n) = COUNT(iDice.eq.n)
END DO
IF(k.eq.12) THEN ! Full
nZeros = COUNT(iAux.eq.0)
nMax = MAXVAL(iAux)
!Condition: there are 3 or 4 dice with the same (nonzero) value
!and at least two more with another value
IF((nZeros.GE.3 .AND. nMax.GT.2 .AND. nMax.LT.5 .AND. &
COUNT(iAux.GE.2).gt.1)) THEN
iSuma1 = 0
iSuma2 = 0
!Take care that combination 111666 equals to (66611), not (66111)
DO n = 1, 6
IF(iAux(n).ge.3) THEN
iTemp = iSuma1
iSuma1 = 3*n+iSuma2
iSuma2 = 2*n+iTemp
ELSE IF(iAux(n).eq.2) THEN
iSuma1 = 2*n+iSuma1
iSuma2 = 2*n+iSuma2
END IF
END DO
iRez = MAX(iSuma1, iSuma2)+30
END IF
END IF
IF(k.eq.13) THEN ! Poker
nMax = MAXVAL(iAux)
IF(nMax.ge.4) THEN
!Actually, this is equal to MAXLOC
DO n = 1, 6
IF(iAux(n).gt.3) THEN
iRez = 4*n+40
EXIT
END IF
END DO
END IF
END IF
IF(k.eq.14) THEN !Yamb
nMax = MAXVAL(iAux)
IF(nMax.ge.5) THEN
DO n = 1, 6
IF(iAux(n).gt.4) THEN
iRez = 5*n+50
EXIT
END IF
END DO
END IF
END IF
END SELECT
IF (k.NE.0) THEN
!Mark the field as complete, and enter the result.
iResult(k, j) = iRez
iState(k, j) = COMPLETE
IF (iState(k, j).eq.0) THEN
iSt = XCtlSet(XW_FRAME, IDC_STATUS, "New roll", 2)
END IF
!If the first column, free the next field, but skip the ones with
!intermediate results
IF(j.eq.1 .AND. K.LT.14) THEN
IF (K+1.EQ.7 .OR. K+1.EQ.10) THEN
iState(k+2, j) = FREE
ELSE
iState(k+1, j) = FREE
END IF
END IF
!If the third column, free the next field, but skip the ones with
!intermediate results
IF(j.eq.3 .AND. K.GT.1) THEN
IF (K-1.EQ.7 .OR. K-1.EQ.10) THEN
iState(k-2, j) = FREE
ELSE
iState(k-1, j) = FREE
END IF
END IF
END IF
!Sum the intermediates
DO n = 1, nColumns
!Rows 1-6
iResult(7, n) = sum(iResult(1:6, n))
IF (iResult(7, n).GE.60) iResult(7, n) = iResult(7, n)+30
!Maximal column
IF (iState(1, n).eq.COMPLETE .AND. iState(8, n).eq.COMPLETE .AND. &
iState(9, n).eq.COMPLETE) THEN
iResult(10, n) = (iResult(8, n)-iResult(9, n))*iResult(1, n)
END IF
!S+F+P+Y
iResult(15, n) = sum(iResult(11:14, n))
END DO
iSt = XMenuSet(xMenu, ID_ACTION_NEWROLL, .TRUE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
iSt = XMenuSet(xMenu, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_NEWROLL, .TRUE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ROLL, .FALSE., XC_ENABLE)
iSt = XToolbarSet(xTb, ID_ACTION_ANNOUNCE, .FALSE., XC_ENABLE)
iTotal = SUM(iResult(7, :))+SUM(iResult(10, :))+SUM(iResult(15, :))
IF (ALL(iState(1:15, 1:nColumns).EQ.COMPLETE)) CALL GameOver
END SUBROUTINE CalcResult
!=======================================================
!PURPOSE: called when the game is over.
SUBROUTINE GameOver()
!USE XFLOGM2
INTEGER:: iSt, i, hKey, iType
TYPE(X_WINDOW):: Dlg
INCLUDE "Resource.fd"
IF(ALL(iTopTenResult.GE.iTotal)) THEN
!"No luck" dialog
iSt = XLoadDialog(IDD_FAIL, Dlg, XW_FRAME)
iSt = XModalDialog(Dlg)
CALL XDestroyDialog(Dlg)
ELSE
!Updating top ten
DO i = 10, 1, -1
!Move current positions downwards
IF (i.NE.10) THEN
sTopTenName(i+1) = sTopTenName(i)
iTopTenResult(i+1) = iTopTenResult(i)
END IF
!Insert the top ten & exit
IF(i.EQ.1 .OR. iTotal.LT.iTopTenResult(i-1) ) THEN
sTopTenName(i) = sPlayerName
iTopTenResult(i) = iTotal
EXIT
END IF
END DO
!Display the dialog & write the registry
CALL OnTopTen(XW_FRAME, 0, 0)
hKey = XRegOpen(HKEY_LOCAL_MACHINE, APP_REGKEY)
iSt = XRegWrite(hKey, "TopTenResult", LOC(iTopTenResult), SIZEOF(iTopTenResult))
iSt = XRegWrite(hKey, "TopTenName", LOC(sTopTenName), SIZEOF(sTopTenName))
CALL XRegClose(hKey)
END IF
!Ask for continuation
iSt = XLoadDialog(IDD_CONTINUE, Dlg, XW_FRAME)
iSt = XModalDialog(Dlg)
CALL XDestroyDialog(Dlg)
IF (iSt.EQ.IDOK) THEN
CALL OnNewGame(XW_FRAME, 0, 0)
ELSE
CALL OnExit(XW_FRAME, 0, 0)
END IF
END SUBROUTINE GameOver
!=======================================================
!PURPOSE: unlocks all fields which are not written
SUBROUTINE ResetState
INTEGER:: k
DO k = 1, 14
IF(iState(k, 4).ne.COMPLETE) iState(k, 4) = LOCKED !Disable announced column
IF(iState(k, 2).ne.COMPLETE) iState(k, 2) = FREE !Enable free column
END DO
DO k = 1, 14
IF(iState(k, 1).ne.COMPLETE) THEN
iState(k, 1) = FREE !Enable remainder of first column
EXIT
END IF
END DO
DO k = 14, 1, -1
IF(iState(k, 3).ne.COMPLETE) THEN
iState(k, 3) = FREE !Enable remainder of third column
EXIT
END IF
END DO
END SUBROUTINE ResetState
!=======================================================
END MODULE XYamb