|
|
|---|
|
|
|
|
|
|
|
|
|
|
|
|
|
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)