Menu
▾
▴
htoolkit-cvs — HToolkit CVS commit messages
You can subscribe to this list here.
| 2003 |
Jan
(30) |
Feb
(20) |
Mar
(151) |
Apr
(86) |
May
(23) |
Jun
(25) |
Jul
(107) |
Aug
(141) |
Sep
(55) |
Oct
(85) |
Nov
(65) |
Dec
(2) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2004 |
Jan
(22) |
Feb
(18) |
Mar
(3) |
Apr
(16) |
May
(69) |
Jun
(3) |
Jul
(1) |
Aug
(3) |
Sep
(1) |
Oct
|
Nov
(6) |
Dec
(1) |
| 2005 |
Jan
(2) |
Feb
(16) |
Mar
|
Apr
|
May
|
Jun
(47) |
Jul
(1) |
Aug
|
Sep
(6) |
Oct
(4) |
Nov
|
Dec
(34) |
| 2006 |
Jan
(39) |
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
(5) |
Oct
|
Nov
(4) |
Dec
|
| 2007 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(1) |
| 2008 |
Jan
|
Feb
|
Mar
(26) |
Apr
(1) |
May
(1) |
Jun
|
Jul
(5) |
Aug
(2) |
Sep
(8) |
Oct
(8) |
Nov
(22) |
Dec
(30) |
| 2009 |
Jan
(10) |
Feb
(13) |
Mar
(14) |
Apr
(14) |
May
(32) |
Jun
(25) |
Jul
(36) |
Aug
(10) |
Sep
(2) |
Oct
|
Nov
|
Dec
(10) |
| 2010 |
Jan
(9) |
Feb
(4) |
Mar
(2) |
Apr
(1) |
May
(2) |
Jun
(2) |
Jul
(1) |
Aug
(4) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
|
From: <kr_...@us...> - 2003-07-02 20:04:48
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv23825/src/Graphics/UI/GIO
Modified Files:
Window.hs Layout.hs
Log Message:
better support for control layout. In the new scheme the controls are placed into the domain rectangle instead of view rectangle
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** Window.hs 8 Jun 2003 19:42:13 -0000 1.19
--- Window.hs 2 Jul 2003 20:04:45 -0000 1.20
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Window
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Window
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 12,16 ****
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize
, dialog, runDialog
, drawInWindow
--- 12,16 ----
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize, layoutSize
, dialog, runDialog
, drawInWindow
***************
*** 89,100 ****
relayoutWindow :: Window -> IO ()
relayoutWindow w
! = do lay <- getVar (vlayout w)
! adjust <- get w autosize
! when adjust (
! do needed <- getLayoutSize lay
! avail <- get w view
! isresize <- get w resizeable
! when (not (sizeEncloses avail needed)) (set w [view =: needed]))
! layoutInWindow (hwindow w) lay
return ()
--- 89,100 ----
relayoutWindow :: Window -> IO ()
relayoutWindow w
! = do view <- get w view
! domain <- get w domain
! lay <- getVar (vlayout w)
! needed <- getLayoutSize lay
! let d1 = maxSize domain needed
! d2 = maxSize d1 view
! Lib.setWindowDomainSize (hwindow w) d1
! layoutInRect (rectOfSize d2) lay
return ()
***************
*** 122,126 ****
domain
= newAttr (\w -> getVar (vdomain w))
! (\w x -> do Lib.setWindowDomainSize (hwindow w) x; setVar (vdomain w) x)
-- | Can the window be resized?
--- 122,126 ----
domain
= newAttr (\w -> getVar (vdomain w))
! (\w x -> setVar (vdomain w) x >> relayoutWindow w)
-- | Can the window be resized?
***************
*** 135,141 ****
view :: Attr Window Size
view
! = newAttr (\w -> Lib.getWindowViewSize (hwindow w))
! (\w sz-> Lib.setWindowViewSize (hwindow w) sz)
!
instance Dismissible Window where
dismissWidget w = Lib.dismissWindow (hwindow w)
--- 135,141 ----
view :: Attr Window Size
view
! = newAttr (Lib.getWindowViewSize . hwindow)
! (Lib.setWindowViewSize . hwindow)
!
instance Dismissible Window where
dismissWidget w = Lib.dismissWindow (hwindow w)
***************
*** 197,202 ****
layout :: Control c => Attr Window c
layout
! = writeAttr "layout" (\w c -> do setVar (vlayout w) (pack c); relayoutWindow w)
!
-- | The drawInWindow executes the given function with canvas
-- associated with given window.
--- 197,218 ----
layout :: Control c => Attr Window c
layout
! = writeAttr "layout" (\w c -> do
! let lay = pack c
! autosize <- get w autosize
! domain <- get w domain
! needed <- getLayoutSize lay
! let d = maxSize domain needed
! Lib.setWindowDomainSize (hwindow w) d
! when autosize (set w [view =: d])
! view <- get w view
! layoutInRect (rectOfSize (maxSize d view)) lay
! setVar (vlayout w) lay)
!
! -- | The layoutSize of window is the minimum size needed to layout
! -- the controls assigned to it.
! layoutSize :: Attr Window Size
! layoutSize
! = readAttr "layoutSize" (\w -> getVar (vlayout w) >>= getLayoutSize)
!
-- | The drawInWindow executes the given function with canvas
-- associated with given window.
Index: Layout.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Layout.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Layout.hs 8 Jun 2003 19:42:13 -0000 1.5
--- Layout.hs 2 Jul 2003 20:04:45 -0000 1.6
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Layout
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Layout
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 114,118 ****
, stdPackChangingLayout
, getLayoutSize
- , layoutInWindow
, layoutInRect
) where
--- 114,117 ----
***************
*** 267,272 ****
-- | Render the control normally, and than move relative to its rendered position.
! moveBy :: Control c => Vector -> c -> Layout
! moveBy v c = move (\p sz -> pointMove v p) (pack c)
-- | Render the control normally, and than change its position according to its
--- 266,271 ----
-- | Render the control normally, and than move relative to its rendered position.
! moveBy :: Control c => Size -> c -> Layout
! moveBy s c = move (\p sz -> pointMove s p) (pack c)
-- | Render the control normally, and than change its position according to its
***************
*** 365,374 ****
sz = rectSize $ foldr rectUnion (rectOfSize (Size 0 0)) rs
return sz
-
- -- | Positions a (layout) control in a certain window (and return the used area)
- layoutInWindow :: Control c => WindowHandle -> c -> IO Size
- layoutInWindow parent c
- = do sz <- Port.getWindowViewSize parent
- layoutInRect (rectAt (pt 0 0) sz) c
-- | Positions a controls in a certain rectangle
--- 364,367 ----
|
|
From: <kr_...@us...> - 2003-07-02 18:09:50
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv3675/src/cbits/Win32
Modified Files:
Window.c
Log Message:
Setup the default page and line steps for scrollers to 1 and 10
Index: Window.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Window.c,v
retrieving revision 1.31
retrieving revision 1.32
diff -C2 -d -r1.31 -r1.32
*** Window.c 8 Jun 2003 10:25:41 -0000 1.31
--- Window.c 2 Jul 2003 18:09:47 -0000 1.32
***************
*** 149,156 ****
pData->DomainSize.cx = 0;
pData->DomainSize.cy = 0;
! pData->LineSize.cx = 0;
! pData->LineSize.cy = 0;
! pData->PageSize.cx = 0;
! pData->PageSize.cy = 0;
pData->bInDragMode = FALSE;
pData->bInMouseMoveMode = FALSE;
--- 149,156 ----
pData->DomainSize.cx = 0;
pData->DomainSize.cy = 0;
! pData->LineSize.cx = 1;
! pData->LineSize.cy = 1;
! pData->PageSize.cx = 10;
! pData->PageSize.cy = 10;
pData->bInDragMode = FALSE;
pData->bInMouseMoveMode = FALSE;
***************
*** 311,326 ****
int nPos = pData->Origin.y;
int nLimit;
- int nLine;
- int nPage;
GetClientRect(hWnd,&rect);
nLimit = pData->DomainSize.cy - (rect.bottom-rect.top);
- /* DAAN: use default scroll when line/page is unspecified: line=10% of view, page=80% of view */
- if (pData->LineSize.cy <= 0) nLine = max(1,(rect.bottom-rect.top)/10);
- else nLine = pData->LineSize.cy;
- if (pData->PageSize.cy <= 0) nPage = max(1,((rect.bottom-rect.top)*8)/10);
- else nPage = pData->PageSize.cy;
-
switch (LOWORD(wParam))
{
--- 311,318 ----
***************
*** 329,348 ****
break;
case SB_LINEDOWN:
! nPos = min(nLimit,pData->Origin.y + nLine);
break;
case SB_LINEUP:
! nPos = max(0,pData->Origin.y - nLine);
break;
case SB_PAGEDOWN:
! nPos = min(nLimit,pData->Origin.y + nPage);
break;
case SB_PAGEUP:
! nPos = max(0,pData->Origin.y - nPage);
break;
case SB_THUMBPOSITION:
- nPos = (HIWORD(wParam)); /* DAAN: position exactly */
- break;
case SB_THUMBTRACK:
! nPos = (HIWORD(wParam)/nLine)*nLine;
break;
case SB_TOP:
--- 321,338 ----
break;
case SB_LINEDOWN:
! nPos = min(nLimit,pData->Origin.y + pData->LineSize.cy);
break;
case SB_LINEUP:
! nPos = max(0,pData->Origin.y - pData->LineSize.cy);
break;
case SB_PAGEDOWN:
! nPos = min(nLimit,pData->Origin.y + pData->PageSize.cy);
break;
case SB_PAGEUP:
! nPos = max(0,pData->Origin.y - pData->PageSize.cy);
break;
case SB_THUMBPOSITION:
case SB_THUMBTRACK:
! nPos = (HIWORD(wParam)/pData->LineSize.cy)*pData->LineSize.cy;
break;
case SB_TOP:
***************
*** 374,389 ****
int nPos = pData->Origin.x;
int nLimit;
- int nLine;
- int nPage;
GetClientRect(hWnd,&rect);
nLimit = pData->DomainSize.cx - (rect.right-rect.left);
- /* DAAN: use default scroll when line/page is unspecified: line=10% of view, page=80% of view */
- if (pData->LineSize.cx <= 0) nLine = max(1,(rect.right-rect.left)/10);
- else nLine = pData->LineSize.cx;
- if (pData->PageSize.cx <= 0) nPage = max(1,((rect.right-rect.left)*8)/10);
- else nPage = pData->PageSize.cx;
-
switch (LOWORD(wParam))
{
--- 364,371 ----
***************
*** 392,411 ****
break;
case SB_LINEDOWN:
! nPos = min(nLimit,pData->Origin.x + nLine);
break;
case SB_LINEUP:
! nPos = max(0,pData->Origin.x - nLine);
break;
case SB_PAGEDOWN:
! nPos = min(nLimit,pData->Origin.x + nPage);
break;
case SB_PAGEUP:
! nPos = max(0,pData->Origin.x - nPage);
break;
case SB_THUMBPOSITION:
- nPos = (HIWORD(wParam)); /* DAAN: position exactly */
- break;
case SB_THUMBTRACK:
! nPos = (HIWORD(wParam)/nLine)*nLine;
break;
case SB_TOP:
--- 374,391 ----
break;
case SB_LINEDOWN:
! nPos = min(nLimit,pData->Origin.x + pData->LineSize.cx);
break;
case SB_LINEUP:
! nPos = max(0,pData->Origin.x - pData->LineSize.cx);
break;
case SB_PAGEDOWN:
! nPos = min(nLimit,pData->Origin.x + pData->PageSize.cx);
break;
case SB_PAGEUP:
! nPos = max(0,pData->Origin.x - pData->PageSize.cx);
break;
case SB_THUMBPOSITION:
case SB_THUMBTRACK:
! nPos = (HIWORD(wParam)/pData->LineSize.cx)*pData->LineSize.cx;
break;
case SB_TOP:
***************
*** 436,450 ****
int nDelta = GET_WHEEL_DELTA_WPARAM(wParam)/WHEEL_DELTA;
int nPos, nOldPos = pData->Origin.y;
- int nLine;
GetClientRect(hWnd,&rect);
nLimit = pData->DomainSize.cy - (rect.bottom-rect.top);
! /* DAAN: use default scroll when line/page is unspecified: line=10% of view, page=80% of view */
! if (pData->LineSize.cy <= 0) nLine = max(1,(rect.bottom - rect.top)/10);
! else nLine = pData->LineSize.cy;
!
!
! nPos = nOldPos - nDelta*nLine;
nPos = max(0,min(nLimit,nPos));
--- 416,424 ----
int nDelta = GET_WHEEL_DELTA_WPARAM(wParam)/WHEEL_DELTA;
int nPos, nOldPos = pData->Origin.y;
GetClientRect(hWnd,&rect);
nLimit = pData->DomainSize.cy - (rect.bottom-rect.top);
! nPos = nOldPos - nDelta*pData->LineSize.cy;
nPos = max(0,min(nLimit,nPos));
|
|
From: <kr_...@us...> - 2003-07-02 17:50:59
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv32685/src/Graphics/UI/GIO
Modified Files:
Types.hs
Log Message:
The Vector data type was unused and now is removed.
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Types.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Types.hs 8 Jun 2003 19:42:13 -0000 1.12
--- Types.hs 2 Jul 2003 17:50:47 -0000 1.13
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Types
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Types
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 17,38 ****
Size(..), sz
, sizeEncloses
-- ** Point
, Point(..), pt
- , pointFromVec
, pointMove
!
! -- ** Vector
! , Vector(..), vc
! , vecNegate, vecFromPoint
-- ** Rectangle
, Rect(..)
- , rectMoveTo, rectStretchTo
- , rectMove
- , rectUnion
- , rectSect
- , disjointRects
- , rectsDiff
-- *** Construction
--- 17,29 ----
Size(..), sz
, sizeEncloses
+ , maxSize, addh, addv, sizeDistance
-- ** Point
, Point(..), pt
, pointMove
! , pointAdd, pointSub, pointScale
-- ** Rectangle
, Rect(..)
-- *** Construction
***************
*** 40,49 ****
, rectAt
, rectOfSize
-- *** Access
, topLeft, topRight, bottomLeft, bottomRight
! , rectSize, rectIsEmpty, pointInRect, pointToRect
! , centralPoint, centralRect
!
-- * Events
--- 31,50 ----
, rectAt
, rectOfSize
+ , pointToRect
-- *** Access
, topLeft, topRight, bottomLeft, bottomRight
! , rectSize
!
! -- *** Calculations
! , rectMove, rectMoveTo, rectStretchTo
! , rectUnion
! , rectSect
! , disjointRects
! , rectsDiff
! , centralPoint
! , centralRect
! , rectIsEmpty
! , pointInRect
-- * Events
|
|
From: <kr_...@us...> - 2003-07-02 17:48:06
|
Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv32391/src/Port
Modified Files:
Types.hs
Log Message:
The Vector data type was not used and now it is removed
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** Types.hs 8 Jun 2003 19:42:15 -0000 1.20
--- Types.hs 2 Jul 2003 17:48:03 -0000 1.21
***************
*** 4,11 ****
-----------------------------------------------------------------------------------------
{-| Module : Types
! Copyright : (c) Krasimir Angelov & Daan Leijen 2003
License : BSD-style
! Maintainer : ka2...@ya... da...@cs...
Stability : provisional
Portability : portable
--- 4,11 ----
-----------------------------------------------------------------------------------------
{-| Module : Types
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 19,35 ****
-- ** Points
! Point(..), pt, pointFromVec, pointMove, pointMoveBySize, pointAdd, pointSub, pointScale
-- ** Sizes
, Size(..), sz, sizeEncloses, maxSize, addh, addv, sizeDistance
- -- ** Vectors
- , Vector(..), vc, vecNegate, vecOrtogonal, vecFromPoint, vecAdd, vecSub, vecScale, vecDistance
-
-- ** Rectangles
, Rect(..), topLeft, topRight, bottomLeft, bottomRight
, rect, rectAt, rectSize, rectOfSize, rectIsEmpty
! , pointInRect, rectMoveTo, pointToRect, centralPoint, centralRect, rectStretchTo
! , rectMove, disjointRects, rectsDiff, rectUnion, rectSect
-- * Render
--- 19,32 ----
-- ** Points
! Point(..), pt, pointMove, pointAdd, pointSub, pointScale
-- ** Sizes
, Size(..), sz, sizeEncloses, maxSize, addh, addv, sizeDistance
-- ** Rectangles
, Rect(..), topLeft, topRight, bottomLeft, bottomRight
, rect, rectAt, rectSize, rectOfSize, rectIsEmpty
! , pointInRect, rectMove, rectMoveTo, pointToRect, centralPoint, centralRect, rectStretchTo
! , disjointRects, rectsDiff, rectUnion, rectSect
-- * Render
***************
*** 168,181 ****
pt x y = Point x y
! pointFromVec :: Vector -> Point
! pointFromVec (Vector x y)
! = Point x y
!
! pointMove :: Vector -> Point -> Point
! pointMove (Vector dx dy) (Point x y)
! = Point (x+dx) (y+dy)
!
! pointMoveBySize :: Size -> Point -> Point
! pointMoveBySize (Size w h) (Point x y) = Point (x + w) (y + h)
pointAdd :: Point -> Point -> Point
--- 165,170 ----
pt x y = Point x y
! pointMove :: Size -> Point -> Point
! pointMove (Size w h) (Point x y) = Point (x + w) (y + h)
pointAdd :: Point -> Point -> Point
***************
*** 246,286 ****
{-----------------------------------------------------------------------------------------
- Vector
- -----------------------------------------------------------------------------------------}
- -- | A vector with an x and y delta.
- data Vector = Vector
- { vx :: !Int -- ^ delta-x component of a vector
- , vy :: !Int -- ^ delta-y component of a vector
- }
- deriving (Eq,Show,Read)
-
- -- | Short function to construct a vector.
- vc :: Int -> Int -> Vector
- vc dx dy = Vector dx dy
-
- vecNegate :: Vector -> Vector
- vecNegate (Vector x y)
- = Vector (-x) (-y)
-
- vecOrtogonal :: Vector -> Vector
- vecOrtogonal (Vector x y) = (Vector y (-x))
-
- vecFromPoint :: Point -> Vector
- vecFromPoint (Point x y)
- = Vector x y
-
- vecAdd :: Vector -> Vector -> Vector
- vecAdd (Vector x1 y1) (Vector x2 y2) = Vector (x1+x2) (y1+y2)
-
- vecSub :: Vector -> Vector -> Vector
- vecSub (Vector x1 y1) (Vector x2 y2) = Vector (x1-x2) (y1-y2)
-
- vecScale :: Int -> Vector -> Vector
- vecScale v (Vector x y) = Vector (v*x) (v*y)
-
- vecDistance :: Point -> Point -> Vector
- vecDistance (Point x1 y1) (Point x2 y2) = Vector (x2-x1) (y2-y1)
-
- {-----------------------------------------------------------------------------------------
Rectangle
-----------------------------------------------------------------------------------------}
--- 235,238 ----
***************
*** 298,305 ****
deriving (Eq,Show)
! topLeft, topRight, bottomLeft, bottomRight :: Rect -> Point
! topLeft (Rect l t r b) = Point l t
! topRight (Rect l t r b) = Point r t
! bottomLeft (Rect l t r b) = Point l b
bottomRight (Rect l t r b) = Point r b
--- 250,267 ----
deriving (Eq,Show)
! -- | The top left corner of the rectangle
! topLeft :: Rect -> Point
! topLeft (Rect l t r b) = Point l t
!
! -- | The top right corner of the rectangle
! topRight :: Rect -> Point
! topRight (Rect l t r b) = Point r t
!
! -- | The bottom left corner of the rectangle
! bottomLeft :: Rect -> Point
! bottomLeft (Rect l t r b) = Point l b
!
! -- | The bottom right corner of the rectangle
! bottomRight :: Rect -> Point
bottomRight (Rect l t r b) = Point r b
***************
*** 330,333 ****
--- 292,299 ----
pointInRect :: Point -> Rect -> Bool
pointInRect (Point x y) (Rect l t r b) = x >= l && x <= r && y >= t && y <= b
+
+ rectMove :: Size -> Rect -> Rect
+ rectMove (Size w h) (Rect l t r b)
+ = Rect (l+w) (t+h) (r+w) (b+h)
rectMoveTo :: Point -> Rect -> Rect
***************
*** 357,364 ****
rectStretchTo (Size w h) (Rect l t r b)
= Rect l t (l+w) (t+h)
-
- rectMove :: Vector -> Rect -> Rect
- rectMove (Vector x y) (Rect x0 y0 x1 y1)
- = Rect (x0+x) (y0+y) (x1+x) (y1+y)
disjointRects :: Rect -> Rect -> Bool
--- 323,326 ----
|
|
From: <kr_...@us...> - 2003-07-01 21:42:41
|
Update of /cvsroot/htoolkit/port
In directory sc8-pr-cvs1:/tmp/cvs-serv9885
Modified Files:
configure
Log Message:
fix
Index: configure
===================================================================
RCS file: /cvsroot/htoolkit/port/configure,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** configure 8 Jun 2003 19:42:14 -0000 1.12
--- configure 1 Jul 2003 21:38:56 -0000 1.13
***************
*** 204,211 ****
# just for windows: haddock doesn't like /home
case "$hdocdir" in
! /home*) if test -z "$HOMEDRIVE"; then
! # nothing
! echo *
! else
hdocdir="`echo $hdocdir | sed -e 's|/home||'`"
hdocdir="$HOMEDRIVE$hdocdir"
--- 204,208 ----
# just for windows: haddock doesn't like /home
case "$hdocdir" in
! /home*) if test ! -z "$HOMEDRIVE"; then
hdocdir="`echo $hdocdir | sed -e 's|/home||'`"
hdocdir="$HOMEDRIVE$hdocdir"
|
|
From: <kr_...@us...> - 2003-07-01 21:01:02
|
Update of /cvsroot/htoolkit/gio/src/examples/worm
In directory sc8-pr-cvs1:/tmp/cvs-serv24266
Modified Files:
Main.hs
Log Message:
Fix comment for AboutDialog
Index: Main.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/worm/Main.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Main.hs 21 Jun 2003 10:04:29 -0000 1.4
--- Main.hs 1 Jul 2003 20:22:01 -0000 1.5
***************
*** 111,116 ****
runAboutDialog "Worm" "1.0"
"(C) Krasimir Angelov, 2003"
! "The Worm is an example program
! freely distributed with HToolkit"
[] [] [] logo Nothing
--- 111,115 ----
runAboutDialog "Worm" "1.0"
"(C) Krasimir Angelov, 2003"
! "The Worm is an example program\nfreely distributed with HToolkit"
[] [] [] logo Nothing
|
|
From: <kr_...@us...> - 2003-07-01 20:44:04
|
Update of /cvsroot/htoolkit/gio/src/examples/simple
In directory sc8-pr-cvs1:/tmp/cvs-serv29071/simple
Modified Files:
Able.hs ByeDemo.hs ConfirmQuit.hs SimpleDialog.hs
SimpleHello.hs SimpleQuitButton.hs
Log Message:
update samples
Index: Able.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/Able.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Able.hs 2 Apr 2003 21:33:55 -0000 1.4
--- Able.hs 1 Jul 2003 20:44:00 -0000 1.5
***************
*** 3,12 ****
import Graphics.UI.GIO
! main = start MDI [title =: "Able"] demo
demo = do
w1 <- window [title =: "Slave", view =: sz 200 100, domain =: sz 200 80]
! ent <- entry [text =: "Test!"] w1
! btn <- button [text =: "Button"] w1
set w1 [layout =: (hfix 80 ent <<< btn)]
w2 <- window [title =: "Master", view =: sz 200 80, domain =: sz 200 80]
--- 3,12 ----
import Graphics.UI.GIO
! main = start "Able" "1.0" MDI [] demo
demo = do
w1 <- window [title =: "Slave", view =: sz 200 100, domain =: sz 200 80]
! ent <- entry [title =: "Test!"] w1
! btn <- button [title =: "Button"] w1
set w1 [layout =: (hfix 80 ent <<< btn)]
w2 <- window [title =: "Master", view =: sz 200 80, domain =: sz 200 80]
***************
*** 18,26 ****
return ()
where
! enable title b w = do
set w [enabled =: True]
! set b [text =: "Disable " ++ title, on command =: disable title b w]
! disable title b w = do
set w [enabled =: False]
! set b [text =: "Enable " ++ title, on command =: enable title b w]
--- 18,26 ----
return ()
where
! enable name b w = do
set w [enabled =: True]
! set b [title =: "Disable " ++ name, on command =: disable name b w]
! disable name b w = do
set w [enabled =: False]
! set b [title =: "Enable " ++ name, on command =: enable name b w]
Index: ByeDemo.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/ByeDemo.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** ByeDemo.hs 2 Apr 2003 21:33:55 -0000 1.4
--- ByeDemo.hs 1 Jul 2003 20:44:00 -0000 1.5
***************
*** 17,26 ****
import Graphics.UI.GIO
! main = start SDI [] demo -- "start" initializes the GUI.
demo :: IO ()
! demo = do w <- window [title =: "Bye!"]
! l <- label [text =: "Hello World"] w
! b <- button [text =: "Bye"] w
set w [layout =: pad 10 (center l ^^^^ center b)]
set b [on command =: bye l b]
--- 17,26 ----
import Graphics.UI.GIO
! main = start "Bye!" "1.0" SDI [] demo -- "start" initializes the GUI.
demo :: IO ()
! demo = do w <- window []
! l <- label [title =: "Hello World"] w
! b <- button [title =: "Bye"] w
set w [layout =: pad 10 (center l ^^^^ center b)]
set b [on command =: bye l b]
***************
*** 28,31 ****
-- called on the first click, with the window, label, and button as arguments.
bye l b
! = do set l [text =: "Goodbye"]
set b [on command =: halt]
--- 28,31 ----
-- called on the first click, with the window, label, and button as arguments.
bye l b
! = do set l [title =: "Goodbye"]
set b [on command =: halt]
Index: ConfirmQuit.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/ConfirmQuit.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** ConfirmQuit.hs 2 Apr 2003 21:33:55 -0000 1.3
--- ConfirmQuit.hs 1 Jul 2003 20:44:00 -0000 1.4
***************
*** 5,11 ****
main
! = start SDI [] $
! do w <- window [title =: "hello world"
! ,view =: sz 200 200]
set w [on dismiss =: confirmQuit w]
where
--- 5,10 ----
main
! = start "ConfirmQuit" "1.0" SDI [] $
! do w <- window [view =: sz 200 200]
set w [on dismiss =: confirmQuit w]
where
Index: SimpleDialog.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleDialog.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** SimpleDialog.hs 26 Apr 2003 20:23:15 -0000 1.1
--- SimpleDialog.hs 1 Jul 2003 20:44:00 -0000 1.2
***************
*** 5,9 ****
main
! = start SDI [title =: "Simple dialogs"] $ do
fm <- menu [title =: "&Open"] mainMenu
menuitem [title =: "Modal Dialog", on command =: showDialog True Nothing] fm
--- 5,9 ----
main
! = start "Simple dialogs" "1.0" SDI [] $ do
fm <- menu [title =: "&Open"] mainMenu
menuitem [title =: "Modal Dialog", on command =: showDialog True Nothing] fm
***************
*** 12,17 ****
showDialog b parent = do
d <- dialog [title =: "Dialog", frame =: Rect 100 100 500 500] parent
! b1 <- button [text =: "Open Modal Dialog", on command =: showDialog True (Just d)] d
! b2 <- button [text =: "Open Modeless Dialog", on command =: showDialog False (Just d)] d
set d [layout =: pad 10 (center (b1 <<< b2))]
when b (runDialog d)
--- 12,17 ----
showDialog b parent = do
d <- dialog [title =: "Dialog", frame =: Rect 100 100 500 500] parent
! b1 <- button [title =: "Open Modal Dialog", on command =: showDialog True (Just d)] d
! b2 <- button [title =: "Open Modeless Dialog", on command =: showDialog False (Just d)] d
set d [layout =: pad 10 (center (b1 <<< b2))]
when b (runDialog d)
Index: SimpleHello.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleHello.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** SimpleHello.hs 2 Apr 2003 21:33:55 -0000 1.3
--- SimpleHello.hs 1 Jul 2003 20:44:00 -0000 1.4
***************
*** 4,7 ****
main
! = start SDI [] $
! do window [title =: "hello world", view =: sz 200 200]
--- 4,7 ----
main
! = start "hello world" "1.0" SDI [] $
! do window [view =: sz 200 200]
Index: SimpleQuitButton.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleQuitButton.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** SimpleQuitButton.hs 2 Apr 2003 21:33:55 -0000 1.3
--- SimpleQuitButton.hs 1 Jul 2003 20:44:00 -0000 1.4
***************
*** 3,10 ****
import Graphics.UI.GIO
! main = start SDI [] demo
demo :: IO ()
! demo = do w <- window [title =: "Quit demo"]
! q <- button [text =: "Quit", on command =: halt] w
set w [layout =: pad 10 (center q)]
--- 3,10 ----
import Graphics.UI.GIO
! main = start "Quit demo" "1.0" SDI [] demo
demo :: IO ()
! demo = do w <- window []
! q <- button [title =: "Quit", on command =: halt] w
set w [layout =: pad 10 (center q)]
|
|
From: <kr_...@us...> - 2003-07-01 20:17:06
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv20890/src/cbits/Win32
Modified Files:
Util.c
Log Message:
bugfix
Index: Util.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Util.c,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** Util.c 1 May 2003 20:38:26 -0000 1.13
--- Util.c 1 Jul 2003 20:08:18 -0000 1.14
***************
*** 126,130 ****
icc.dwICC = ICC_WIN95_CLASSES;
InitCommonControlsEx(&icc);
!
if (DocumentInterface == 1)
{
--- 126,133 ----
icc.dwICC = ICC_WIN95_CLASSES;
InitCommonControlsEx(&icc);
! }
!
! if (ghWndFrame == NULL)
! {
if (DocumentInterface == 1)
{
***************
*** 207,210 ****
--- 210,214 ----
{
DestroyWindow(ghWndFrame);
+ ghWndFrame = NULL;
}
|
|
From: <kr_...@us...> - 2003-07-01 19:15:11
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv8927
Added Files:
AboutDialog.c
Log Message:
Add implementation for AboutDialog for Windows
--- NEW FILE: AboutDialog.c ---
#include "CommonDialogs.h"
#include "Internals.h"
#define FONT_SIZE 15
#define FONT_FACE "MS Sans Serif"
#define IDC_CREDITS 999
typedef struct
{
HDC hDC;
HFONT hLargeFont, hFont;
int nBaseUnitX, nBaseUnitY;
BitmapHandle bitmap;
char *authors;
char *documenters;
char *translator_credits;
// Dialog template buffer
WORD *pBuffer;
WORD *pBufferPos;
UINT nWordsAllocated;
} DlgInfo;
static BOOL InitDlgInfo(DlgInfo *pdi, BitmapHandle bitmap, char *authors, char *documenters, char *translator_credits)
{
LOGFONT lf;
memset(pdi, 0, sizeof(*pdi));
pdi->bitmap = bitmap;
pdi->authors = authors;
pdi->documenters = documenters;
pdi->translator_credits = translator_credits;
pdi->hDC = CreateDC ("DISPLAY", NULL, NULL, NULL);
if (!pdi->hDC) return FALSE;
lf.lfHeight = -FONT_SIZE*2;
lf.lfWeight = FW_BOLD;
lf.lfItalic = FALSE;
lf.lfUnderline = FALSE;
lf.lfStrikeOut = FALSE;
lf.lfWidth = 0;
lf.lfEscapement = 0;
lf.lfOrientation = 0;
lf.lfCharSet = DEFAULT_CHARSET;
lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
lf.lfQuality = DEFAULT_QUALITY;
lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
strcpy(lf.lfFaceName, FONT_FACE);
pdi->hLargeFont = CreateFontIndirect(&lf);
if (!pdi->hLargeFont) return FALSE;
lf.lfHeight = -FONT_SIZE;
lf.lfWeight = FW_NORMAL;
lf.lfItalic = FALSE;
lf.lfUnderline = FALSE;
lf.lfStrikeOut = FALSE;
lf.lfWidth = 0;
lf.lfEscapement = 0;
lf.lfOrientation = 0;
lf.lfCharSet = DEFAULT_CHARSET;
lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
lf.lfQuality = DEFAULT_QUALITY;
lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
strcpy(lf.lfFaceName, FONT_FACE);
pdi->hFont = CreateFontIndirect(&lf);
if (!pdi->hFont) return FALSE;
pdi->nBaseUnitX = LOWORD(GetDialogBaseUnits());
pdi->nBaseUnitY = HIWORD(GetDialogBaseUnits());
pdi->pBuffer = NULL;
pdi->pBufferPos = NULL;
pdi->nWordsAllocated = 0;
return TRUE;
}
static BOOL FreeDlgInfo(DlgInfo *pdi)
{
if (pdi->hFont) DeleteObject(pdi->hFont);
if (pdi->hLargeFont) DeleteObject(pdi->hLargeFont);
if (pdi->hDC) DeleteDC(pdi->hDC);
if (pdi->pBuffer) free(pdi->pBuffer);
return TRUE;
}
static void ResetBufferPos(DlgInfo *pdi)
{
pdi->pBufferPos = pdi->pBuffer;
}
static WORD *EnsureAtLeastNWords(DlgInfo *pdi, UINT nCount)
{
WORD *pNewBuffer;
UINT nWordsFree;
nWordsFree = pdi->nWordsAllocated-(pdi->pBufferPos-pdi->pBuffer);
if (nWordsFree < nCount)
{
pdi->nWordsAllocated += max(nCount-nWordsFree,128);
pNewBuffer = realloc(pdi->pBuffer, pdi->nWordsAllocated*sizeof(WORD));
pdi->pBufferPos += pNewBuffer - pdi->pBuffer;
pdi->pBuffer = pNewBuffer;
}
return pdi->pBufferPos;
}
static void StoreWord(DlgInfo *pdi, WORD w)
{
EnsureAtLeastNWords(pdi, 1);
*(pdi->pBufferPos)++ = w;
}
static void StoreDWord(DlgInfo *pdi, DWORD dw)
{
EnsureAtLeastNWords(pdi, 1);
*(pdi->pBufferPos)++ = LOWORD(dw);
*(pdi->pBufferPos)++ = HIWORD(dw);
}
static void StoreString(DlgInfo *pdi, char *s)
{
EnsureAtLeastNWords(pdi, strlen(s)+1);
do *(pdi->pBufferPos)++ = (WORD) *s; while (*s++);
}
static void StoreStringZ(DlgInfo *pdi, char *s)
{
EnsureAtLeastNWords(pdi, strlen(s));
while (*s) *(pdi->pBufferPos)++ = (WORD) *s++;
}
static void StoreRect(DlgInfo *pdi, UINT x, UINT y, UINT cx, UINT cy)
{
EnsureAtLeastNWords(pdi, 4);
*(pdi->pBufferPos)++ = x;
*(pdi->pBufferPos)++ = y;
*(pdi->pBufferPos)++ = cx;
*(pdi->pBufferPos)++ = cy;
}
static void AlignBufferPos(DlgInfo *pdi)
{
while ((pdi->pBufferPos-pdi->pBuffer) % (sizeof(DWORD)/sizeof(WORD)))
StoreWord(pdi, 0);
}
static void GetBmpSizeInDlgUnit(DlgInfo *pdi, BitmapHandle bitmap, SIZE *psz)
{
psz->cx = MulDiv(bitmap->destsize.cx,4,pdi->nBaseUnitX);
psz->cy = MulDiv(bitmap->destsize.cy,8,pdi->nBaseUnitY);
}
static void GetTextSizeInDlgUnit(DlgInfo *pdi, char *s, SIZE *psz, BOOL bLarge)
{
RECT rect;
HFONT hOldFont;
memset(&rect, 0, sizeof(rect));
hOldFont = SelectObject(pdi->hDC, (bLarge) ? pdi->hLargeFont : pdi->hFont);
DrawText(pdi->hDC, s, strlen(s), &rect, DT_CALCRECT);
SelectObject(pdi->hDC, hOldFont);
psz->cx = MulDiv(rect.right-rect.left,4,pdi->nBaseUnitX);
psz->cy = MulDiv(rect.bottom-rect.top,8,pdi->nBaseUnitY);
}
static INT_PTR CALLBACK HDetailsDialogFunction(HWND hWnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
{
switch (uMsg)
{
case WM_INITDIALOG:
SendDlgItemMessage(hWnd, 100, WM_SETFONT, (WPARAM) ((DlgInfo *) ((PROPSHEETPAGE *) lParam)->lParam)->hFont, TRUE);
return TRUE;
}
return FALSE;
}
static INT_PTR CALLBACK HAboutDialogFunction(HWND hWnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
{
DlgInfo *pdi;
switch (uMsg)
{
case WM_INITDIALOG:
{
BitmapHandle bitmap;
pdi = (DlgInfo *) lParam;
bitmap = pdi->bitmap;
SetWindowLong(hWnd, DWL_USER, lParam);
if (bitmap->destsize.cx != bitmap->sourcesize.cx || bitmap->destsize.cy != bitmap->sourcesize.cy)
{
HBITMAP hBitmap;
HDC hDC, hDestDC, hSourceDC;
hDC = GetDC(hWnd);
hDestDC = CreateCompatibleDC(hDC);
hSourceDC = CreateCompatibleDC(hDC);
hBitmap = CreateCompatibleBitmap(hDC, bitmap->destsize.cx, bitmap->destsize.cy);
SelectObject(hDestDC, hBitmap);
SelectObject(hSourceDC, bitmap->hBitmap);
StretchBlt(hDestDC, 0, 0, bitmap->destsize.cx, bitmap->destsize.cy, hSourceDC, 0, 0, bitmap->sourcesize.cx, bitmap->sourcesize.cy, SRCCOPY);
DeleteObject(bitmap->hBitmap);
bitmap->hBitmap = hBitmap;
bitmap->sourcesize = bitmap->destsize;
DeleteDC(hSourceDC);
DeleteDC(hDestDC);
ReleaseDC(hWnd,hDC);
}
SendDlgItemMessage(hWnd, 100, STM_SETIMAGE, IMAGE_BITMAP, (LPARAM) bitmap->hBitmap);
SendDlgItemMessage(hWnd, 101, WM_SETFONT, (WPARAM) pdi->hLargeFont, TRUE);
SendDlgItemMessage(hWnd, 102, WM_SETFONT, (WPARAM) pdi->hFont, TRUE);
SendDlgItemMessage(hWnd, 103, WM_SETFONT, (WPARAM) pdi->hFont, TRUE);
SendDlgItemMessage(hWnd, IDC_CREDITS, WM_SETFONT, (WPARAM) pdi->hFont, TRUE);
SendDlgItemMessage(hWnd, 104, WM_SETFONT, (WPARAM) pdi->hFont, TRUE);
SendDlgItemMessage(hWnd, IDOK,WM_SETFONT, (WPARAM) pdi->hFont, TRUE);
}
return TRUE;
case WM_CLOSE:
EndDialog(hWnd,0);
return TRUE;
case WM_COMMAND:
switch (LOWORD(wParam))
{
case IDOK:
EndDialog(hWnd,0);
return TRUE;
case IDC_CREDITS:
{
SIZE sz;
PROPSHEETHEADER psh;
PROPSHEETPAGE psp[3];
int nPageIndex, n;
char *s;
pdi = (DlgInfo *) GetWindowLong(hWnd, DWL_USER);
nPageIndex = 0;
memset(&psp, 0, sizeof(psp));
ResetBufferPos(pdi);
if (pdi->authors)
{
psp[nPageIndex].dwSize = sizeof(PROPSHEETPAGE);
psp[nPageIndex].dwFlags= PSP_DLGINDIRECT;
psp[nPageIndex].hInstance = ghModule;
psp[nPageIndex].pResource = (LPCDLGTEMPLATE) pdi->pBufferPos;
psp[nPageIndex].pfnDlgProc = HDetailsDialogFunction;
psp[nPageIndex].lParam = (LPARAM) pdi;
nPageIndex++;
n = 0;
s = pdi->authors;
for (;;)
{
if (*s) n++;
else
{
if (n == 0)
break;
n = 0;
*s = '\n';
}
s++;
}
GetTextSizeInDlgUnit(pdi,pdi->authors,&sz,FALSE);
// start to fill in the dlgtemplate information. Addressing by WORDs
StoreDWord(pdi, 0); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreWord(pdi, 1); // NumberOfItems
StoreRect(pdi, 0,0,
MulDiv(sz.cx,4,3)+4,MulDiv(sz.cy,4,3)+4); // rect
StoreWord(pdi, 0); // Menu
StoreWord(pdi, 0); // Default dialog class
StoreString(pdi, "Written by"); // Title
// start fill in the control templates
AlignBufferPos(pdi);
// comments
StoreDWord(pdi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreRect(pdi, 2,2,sz.cx,sz.cy); // rect
StoreWord(pdi, 100); // control id
StoreDWord(pdi, 0x0082FFFF); // control class 'STATIC'
StoreString(pdi, pdi->authors);
StoreWord(pdi, 0);
}
if (pdi->documenters)
{
psp[nPageIndex].dwSize = sizeof(PROPSHEETPAGE);
psp[nPageIndex].dwFlags= PSP_DLGINDIRECT;
psp[nPageIndex].hInstance = ghModule;
psp[nPageIndex].pResource = (LPCDLGTEMPLATE) pdi->pBufferPos;
psp[nPageIndex].pfnDlgProc = HDetailsDialogFunction;
psp[nPageIndex].lParam = (LPARAM) pdi;
nPageIndex++;
n = 0;
s = pdi->authors;
for (;;)
{
if (*s) n++;
else
{
if (n == 0)
break;
n = 0;
*s = (WORD) '\n';
}
s++;
}
GetTextSizeInDlgUnit(pdi,pdi->authors,&sz,FALSE);
// start to fill in the dlgtemplate information. Addressing by WORDs
StoreDWord(pdi, 0); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreWord(pdi, 1); // NumberOfItems
StoreRect(pdi, 0,0,
MulDiv(sz.cx,4,3)+4,MulDiv(sz.cy,4,3)+4); // rect
StoreWord(pdi, 0); // Menu
StoreWord(pdi, 0); // Default dialog class
StoreString(pdi, "Documented by"); // Title
// start fill in the control templates
AlignBufferPos(pdi);
// comments
StoreDWord(pdi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreRect(pdi, 2,2,sz.cx,sz.cy); // rect
StoreWord(pdi, 100); // control id
StoreDWord(pdi, 0x0082FFFF); // control class 'STATIC'
StoreString(pdi, pdi->documenters);
StoreWord(pdi, 0);
}
if (pdi->translator_credits)
{
psp[nPageIndex].dwSize = sizeof(PROPSHEETPAGE);
psp[nPageIndex].dwFlags= PSP_DLGINDIRECT;
psp[nPageIndex].hInstance = ghModule;
psp[nPageIndex].pResource = (LPCDLGTEMPLATE) pdi->pBufferPos;
psp[nPageIndex].pfnDlgProc = HDetailsDialogFunction;
psp[nPageIndex].lParam = (LPARAM) pdi;
nPageIndex++;
GetTextSizeInDlgUnit(pdi,pdi->authors,&sz,FALSE);
// start to fill in the dlgtemplate information. Addressing by WORDs
StoreDWord(pdi, 0); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreWord(pdi, 1); // NumberOfItems
StoreRect(pdi, 0,0,
MulDiv(sz.cx,4,3)+4,MulDiv(sz.cy,4,3)+4); // rect
StoreWord(pdi, 0); // Menu
StoreWord(pdi, 0); // Default dialog class
StoreString(pdi, "Translated by"); // Title
// start fill in the control templates
AlignBufferPos(pdi);
// comments
StoreDWord(pdi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(pdi, 0); // lExtendedStyle
StoreRect(pdi, 2,2,sz.cx,sz.cy); // rect
StoreWord(pdi, 100); // control id
StoreDWord(pdi, 0x0082FFFF); // control class 'STATIC'
StoreString(pdi, pdi->translator_credits);
StoreWord(pdi, 0);
}
memset(&psh, 0, sizeof(psh));
psh.dwSize = sizeof(psh);
psh.dwFlags = PSH_PROPSHEETPAGE | PSH_NOAPPLYNOW;
psh.hwndParent = hWnd;
psh.hInstance = ghModule;
psh.pszCaption = "Details";
psh.nPages = nPageIndex;
psh.ppsp = &psp;
PropertySheet(&psh);
};
return TRUE;
}
break;
}
return FALSE;
}
void osRunAboutDialog(char *appName, char *appVersion, char *copyright, char *comments, char *authors, char *documenters, char *translator_credits, BitmapHandle bitmap, WindowHandle owner)
{
char *s;
int nDlgWidth, nDlgHeight;
SIZE sz1, sz2, sz3, bmpSize;
DlgInfo fi;
if (!owner) owner = ghWndFrame;
if (!InitDlgInfo(&fi, bitmap, authors, documenters, translator_credits))
return;
s = (char *) EnsureAtLeastNWords(&fi, (strlen(appName)+strlen(appVersion)+3)/2);
strcpy(s,appName);
strcat(s," ");
strcat(s,appVersion);
GetTextSizeInDlgUnit(&fi,s, &sz1, TRUE);
GetTextSizeInDlgUnit(&fi,comments, &sz2, FALSE);
GetTextSizeInDlgUnit(&fi,copyright, &sz3, FALSE);
GetBmpSizeInDlgUnit (&fi,bitmap, &bmpSize);
nDlgWidth = bmpSize.cx + max(max(sz1.cx,max(sz2.cx,sz3.cx)),50)+6;
nDlgHeight = max(bmpSize.cy,sz1.cy+(sz2.cy+sz3.cy)+20)+30;
ResetBufferPos(&fi);
// start to fill in the dlgtemplate information. Addressing by WORDs
StoreDWord(&fi, WS_CAPTION | WS_SYSMENU | DS_CENTER | DS_MODALFRAME); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreWord(&fi, 7); // NumberOfItems
StoreRect(&fi, 0, 0, nDlgWidth, nDlgHeight); // rect
StoreWord(&fi, 0); // Menu (empty)
StoreWord(&fi, 0); // Default dialog class
StoreStringZ(&fi, "About ");
StoreString(&fi, appName);
// start fill in the control templates
AlignBufferPos(&fi);
// icon
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | SS_BITMAP | SS_CENTERIMAGE); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, 2, 2,
bmpSize.cx, bmpSize.cy); // rect
StoreWord(&fi, 100); // control id
StoreDWord(&fi,0x0082FFFF); // control class 'STATIC'
StoreWord(&fi, 0); // empty title
StoreWord(&fi, 0);
AlignBufferPos(&fi);
// app name & version
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, bmpSize.cx+4,2,
nDlgWidth-bmpSize.cx-2,sz1.cy); // rect
StoreWord(&fi, 101); // control id
StoreDWord(&fi, 0x0082FFFF); // control class 'STATIC'
StoreStringZ(&fi, appName);
StoreWord(&fi, ' ');
StoreString(&fi, appVersion);
StoreWord(&fi, 0);
AlignBufferPos(&fi);
// comments
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, bmpSize.cx+4, sz1.cy+3,
nDlgWidth-bmpSize.cx-2,sz2.cy); // rect
StoreWord(&fi, 102); // control id
StoreDWord(&fi, 0x0082FFFF); // control class 'STATIC'
StoreString(&fi, comments);
StoreWord(&fi, 0);
AlignBufferPos(&fi);
// copyright
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | SS_NOPREFIX | SS_LEFT); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, bmpSize.cx+4,sz1.cy+sz2.cy+4,
nDlgWidth-bmpSize.cx-2,sz3.cy); // rect
StoreWord(&fi, 103); // control id
StoreDWord(&fi, 0x0082FFFF); // control class 'STATIC'
StoreString(&fi, copyright);
StoreDWord(&fi, 0);
AlignBufferPos(&fi);
// Credits button
if (authors || documenters || translator_credits)
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | BS_PUSHBUTTON); // lStyle ( visible )
else
StoreDWord(&fi, WS_CHILD | BS_PUSHBUTTON); // lStyle ( invisible )
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, nDlgWidth-52, sz1.cy+sz2.cy+sz3.cy+5,
50, 16); // rect
StoreWord(&fi, IDC_CREDITS); // control id
StoreDWord(&fi, 0x0080FFFF); // control class 'BUTTON'
StoreString(&fi, "Credits...");
StoreWord(&fi, 0);
AlignBufferPos(&fi);
// horizontal separator line
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | BS_GROUPBOX); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, 2, max(bmpSize.cy,sz1.cy+sz2.cy+sz3.cy+20)+2,
nDlgWidth-4, 4); // rect
StoreWord(&fi, 104); // control id
StoreDWord(&fi, 0x0080FFFF); // control class 'BUTTON'
StoreWord(&fi, 0);
StoreWord(&fi, 0);
AlignBufferPos(&fi);
// OK button
StoreDWord(&fi, WS_VISIBLE | WS_CHILD | BS_DEFPUSHBUTTON); // lStyle
StoreDWord(&fi, 0); // lExtendedStyle
StoreRect(&fi, nDlgWidth-52, max(bmpSize.cy,sz1.cy+sz2.cy+sz3.cy+20)+10,
50, 16); // rect
StoreWord(&fi, IDOK); // control id
StoreDWord(&fi, 0x0080FFFF); // control class 'BUTTON'
StoreString(&fi, "OK");
StoreWord(&fi, 0);
DialogBoxIndirectParam(ghModule, (LPCDLGTEMPLATE) fi.pBuffer, owner, HAboutDialogFunction, (LPARAM) &fi);
FreeDlgInfo(&fi);
}
|
|
From: <kr_...@us...> - 2003-06-21 10:14:50
|
Update of /cvsroot/htoolkit/gio/src/examples/simple
In directory sc8-pr-cvs1:/tmp/cvs-serv18900a
Modified Files:
Calculator.hs Progress.hs SimpleMenu.hs
Log Message:
Formatting
Index: Calculator.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/Calculator.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Calculator.hs 17 Jun 2003 17:05:39 -0000 1.5
--- Calculator.hs 21 Jun 2003 10:14:47 -0000 1.6
***************
*** 10,16 ****
calculator
= do varst <- newVar (0,id)
! w <- window []
display <- label [title =: "0"] w
! keys <- mapM (\c -> button [title =: [c], on command =: cmd varst display c] w) "123+456-789*C0=/"
set w [layout =: (pad 10 (hglue <<< display)) ^^^ grid (matrix 4 (map (hfix 50) keys))]
where
--- 10,18 ----
calculator
= do varst <- newVar (0,id)
! w <- window [resizeable =: True]
display <- label [title =: "0"] w
! keys <- mapM (\c -> button [title =: [c]
! ,on command =: cmd varst display c] w)
! "123+456-789*C0=/"
set w [layout =: (pad 10 (hglue <<< display)) ^^^ grid (matrix 4 (map (hfix 50) keys))]
where
Index: Progress.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/Progress.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Progress.hs 30 May 2003 13:07:06 -0000 1.3
--- Progress.hs 21 Jun 2003 10:14:47 -0000 1.4
***************
*** 9,27 ****
demo = do
! w <- window [view =: sz 800 100, domain =: sz 800 80]
! tm <- timer [interval =: maxSpeed `div` 2]
! prg <- hProgressBar True [range =: (0,maxProgress)] w
! lbl <- label [title =: "Speed"] w
! sld <- hslider [range =: (0,maxSpeed), selectedPos =: maxSpeed `div` 2] w
! set w [layout =: (hfill prg ^^^ (lbl <<< hfill sld))]
! set tm [on command =: set prg [selectedPos ~: next]]
! set sld [on command =: changeSpeed tm sld]
! set w [on destroy =: destroyWidget tm]
! return ()
! where
! next x | x >= maxProgress = 0
! | otherwise = x+1
! changeSpeed tm sld = do
! pos <- get sld selectedPos
! set tm [interval =: maxSpeed-pos+20]
--- 9,27 ----
demo = do
! w <- window [view =: sz 800 100, domain =: sz 800 80]
! tm <- timer [interval =: maxSpeed `div` 2]
! prg <- hProgressBar True [range =: (0,maxProgress)] w
! lbl <- label [title =: "Speed"] w
! sld <- hslider [range =: (0,maxSpeed), selectedPos =: maxSpeed `div` 2] w
! set w [layout =: (hfill prg ^^^ (lbl <<< hfill sld))]
! set tm [on command =: set prg [selectedPos ~: next]]
! set sld [on command =: changeSpeed tm sld]
! set w [on destroy =: destroyWidget tm]
! return ()
! where
! next x | x >= maxProgress = 0
! | otherwise = x+1
! changeSpeed tm sld = do
! pos <- get sld selectedPos
! set tm [interval =: maxSpeed-pos+20]
Index: SimpleMenu.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleMenu.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** SimpleMenu.hs 17 Jun 2003 17:05:39 -0000 1.6
--- SimpleMenu.hs 21 Jun 2003 10:14:47 -0000 1.7
***************
*** 12,20 ****
fm <- menu [title =: "&File"] mainMenu
! menuitem [title =: "&New", accel =: KeyChar '\^N', on command =: messageAlert "NEW", menuicon =: Just bmpNew] fm
! menuitem [title =: "&Open", accel =: KeyChar '\^O', on command =: messageAlert "OPEN", menuicon =: Just bmpOpen] fm
menuitem [title =: "&Close"] fm
menuline fm
! menuitem [title =: "&Save", accel =: KeyChar '\^S', on command =: messageAlert "SAVE", menuicon =: Just bmpSave] fm
menuline fm
menuitem [title =: "&Exit", on command =: halt] fm
--- 12,32 ----
fm <- menu [title =: "&File"] mainMenu
! menuitem [title =: "&New"
! ,accel =: KeyChar '\^N'
! ,on command =: messageAlert "NEW"
! ,menuicon =: Just bmpNew
! ] fm
! menuitem [title =: "&Open"
! ,accel =: KeyChar '\^O'
! , on command =: messageAlert "OPEN"
! , menuicon =: Just bmpOpen
! ] fm
menuitem [title =: "&Close"] fm
menuline fm
! menuitem [title =: "&Save"
! ,accel =: KeyChar '\^S'
! ,on command =: messageAlert "SAVE"
! , menuicon =: Just bmpSave
! ] fm
menuline fm
menuitem [title =: "&Exit", on command =: halt] fm
|
|
From: <kr_...@us...> - 2003-06-21 10:04:32
|
Update of /cvsroot/htoolkit/gio/src/examples/worm
In directory sc8-pr-cvs1:/tmp/cvs-serv17905
Modified Files:
HighScore.hs Main.hs WormShow.hs WormState.hs
Log Message:
Formatting
Index: HighScore.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/worm/HighScore.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HighScore.hs 7 Jun 2003 18:30:05 -0000 1.1
--- HighScore.hs 21 Jun 2003 10:04:29 -0000 1.2
***************
*** 1,10 ****
module HighScore
! ( HiScores, HiScore(..)
! , readHiScores
! , writeHiScores
! , itsAHighScore
! , addScore
! , showHiScores
! ) where
import Graphics.UI.GIO
--- 1,10 ----
module HighScore
! ( HiScores, HiScore(..)
! , readHiScores
! , writeHiScores
! , itsAHighScore
! , addScore
! , showHiScores
! ) where
import Graphics.UI.GIO
***************
*** 13,60 ****
data HiScore
= HiScore
! { name :: !String
! , score :: !Int
! }
! deriving (Show,Read)
! -- Read in the high scores:
readHiScores :: FilePath -> IO HiScores
readHiScores fname = do
! content <- fmap lines (readFile fname)
! return (map read content)
! -- Write the high scores:
writeHiScores :: FilePath -> HiScores -> IO ()
writeHiScores fname highs = do
! let content = map show highs
! writeFile fname (unlines content)
! -- Determine whether, given the number of high scores, a given score is actually a new high score:
itsAHighScore :: Int -> Int -> HiScores -> Bool
itsAHighScore nrOfHiScores score' hiscores
! | score'==0 = False
! | length hiscores<nrOfHiScores = True
! | otherwise = any (\hiscore -> score' > score hiscore) hiscores
!
! -- Add a HiScore to the current list of high scores:
addScore :: Int -> HiScore -> HiScores -> HiScores
addScore nrOfHighScores hi hiscores =
! take nrOfHighScores (addscore hi hiscores)
! where
! addscore :: HiScore -> HiScores -> HiScores
! addscore hi' hiscores@(hi:his)
! | score hi > score hi' = hi : addscore hi' his
! | otherwise = hi' : hiscores
! addscore hi [] = [hi]
! -- Display high scores in a modal dialog to the user:
showHiScores :: String -> HiScores -> IO ()
showHiScores header highs = do
! w <- dialog [title =: "High Scores", resizeable =: False] Nothing
! hdr <- label [title =: header] w
! btnOK <- button [title =: "OK", on command =: dismissWidget w >> return ()] w
! cs <- sequence [label [title =: show hi++". "++take 20 name++" "++show score] w
! | (hi,HiScore{name=name,score=score}) <- zip [1..] highs]
! set w [layout =: padding 10 (padding 15 hdr ^^^ column cs ^^^ padding 15 (hcenter btnOK))]
! runDialog w
--- 13,60 ----
data HiScore
= HiScore
! { name :: !String
! , score :: !Int
! }
! deriving (Show,Read)
! -- Read in the high scores:
readHiScores :: FilePath -> IO HiScores
readHiScores fname = do
! content <- fmap lines (readFile fname)
! return (map read content)
! -- Write the high scores:
writeHiScores :: FilePath -> HiScores -> IO ()
writeHiScores fname highs = do
! let content = map show highs
! writeFile fname (unlines content)
! -- Determine whether, given the number of high scores, a given score is actually a new high score:
itsAHighScore :: Int -> Int -> HiScores -> Bool
itsAHighScore nrOfHiScores score' hiscores
! | score'== 0 = False
! | length hiscores<nrOfHiScores = True
! | otherwise = any (\hiscore -> score' > score hiscore) hiscores
!
! -- Add a HiScore to the current list of high scores:
addScore :: Int -> HiScore -> HiScores -> HiScores
addScore nrOfHighScores hi hiscores =
! take nrOfHighScores (addscore hi hiscores)
! where
! addscore :: HiScore -> HiScores -> HiScores
! addscore hi' hiscores@(hi:his)
! | score hi > score hi' = hi : addscore hi' his
! | otherwise = hi' : hiscores
! addscore hi [] = [hi]
! -- Display high scores in a modal dialog to the user:
showHiScores :: String -> HiScores -> IO ()
showHiScores header highs = do
! w <- dialog [title =: "High Scores", resizeable =: False] Nothing
! hdr <- label [title =: header] w
! btnOK <- button [title =: "OK", on command =: dismissWidget w >> return ()] w
! cs <- sequence [label [title =: show hi++". "++take 20 name++" "++show score] w
! | (hi,HiScore{name=name,score=score}) <- zip [1..] highs]
! set w [layout =: padding 10 (padding 15 hdr ^^^ column cs ^^^ padding 15 (hcenter btnOK))]
! runDialog w
Index: Main.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/worm/Main.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Main.hs 8 Jun 2003 11:11:03 -0000 1.3
--- Main.hs 21 Jun 2003 10:04:29 -0000 1.4
***************
*** 4,8 ****
import WormShow
import WormState
- --import Help
import HighScore
import System.Random
--- 4,7 ----
***************
*** 11,500 ****
! -- GUI constants.
hiScoresFile = "wormhi"
nrOfHiScores = 8
! -- Start of the program.
main :: IO ()
main = do
! hiscores <- readHiScores hiScoresFile
! start "Worm" "1.0" SDI [] (startWorm hiscores)
startWorm :: HiScores -> IO ()
startWorm best = do
! ref <- newIORef (initState best)
! -- File menu
! mfile <- menu [title =: "File"] mainMenu
! mnew <- menuitem [title =: "New", accel =: KeyChar '\^N'] mfile
! mplay <- menuitem [title =: "Play", accel =: KeyChar '\^P'] mfile
! menuline mfile
! mexit <- menuitem [title =: "Exit", on command =: halt] mfile
!
! -- Options menu
! mopts <- menu [title =: "Options"] mainMenu
! mspeed <- menuRadioGroup [] mopts
! menuRadioItem [title =: "Slow", on command =: onSetSpeed ref easySpeed ] mspeed
! menuRadioItem [title =: "Medium", on command =: onSetSpeed ref mediumSpeed] mspeed
! menuRadioItem [title =: "Fast", on command =: onSetSpeed ref hardSpeed ] mspeed
! menuline mopts
! menuitem [title =: "High Scores", accel =: KeyChar '\^S', on command =: onShowBest ref] mopts
!
! -- Help menu
! mhelp <- menu [title =: "Help"] mainMenu
! menuitem [title =: "About Worm...", on command =: onAbout] mhelp
!
! -- Main window
! w <- window [ bgcolor =: wormBackGroundColour
! , bkDrawMode =: True
! , view =: Size 488 303
! , on paint =: onPaint ref
! , on dismiss =: halt
! , resizeable =: False
! ]
!
! -- Timer
! tm <- timer [enabled =: False]
! set tm [on command =: onTimer ref mnew mopts mplay mexit tm w]
!
! set mplay [on command =: onPlay ref mnew mopts mplay mexit tm w]
! set mnew [on command =: onNew ref w]
onPaint ref can _ _ = do
! state <- readIORef ref
! let (State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}) = state
! drawGame state can
onNew ref w = do
! modifyIORef ref (initState . best)
! repaint w
onPlay ref mnew mopts mplay mexit tm w = do
! state <- readIORef ref
! set mplay [title =: "Stop", on command =: onStop ref mnew mopts mplay mexit tm w]
! set mnew [enabled =: False]
! set mopts [enabled =: False]
! set mexit [enabled =: False]
! set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
! set tm [enabled =: True, interval =: speed (gamelevel state)]
onStop ref mnew mopts mplay mexit tm w = do
! set mplay [title =: "Play", on command =: onPlay ref mnew mopts mplay mexit tm w]
! set mnew [enabled =: True]
! set mopts [enabled =: True]
! set mexit [enabled =: True]
! set w [off keyboard]
! set tm [enabled =: False]
!
onHalt ref mnew mopts mplay mexit tm w = do
! onStop ref mnew mopts mplay mexit tm w
! onNew ref w
!
onAbout = do
! logo <- readBitmap "logo.bmp" []
! runAboutDialog "Worm" "1.0" "(C) Krasimir Angelov, 2003" "The Worm is an example program\nfreely distributed with HToolkit" [] [] [] logo Nothing
!
onSetSpeed ref speed =
! modifyIORef ref (\state -> state{gamelevel=(gamelevel state){fix=speed,speed=speed}})
onShowBest ref = do
! state <- readIORef ref
! showHiScores "Worm High Scores:" (best state)
onTimer ref mnew mopts mplay mexit tm w = do
! state <- readIORef ref
! let (event,state1) = stepGame state
! writeIORef ref state1
! case event of
! IncreaseLevel -> switchLevel state1
! DecreaseLevel -> switchLevel state1
! Collide -> nextLife state
! _ -> drawInWindow UnBuffered w (drawStep state state1)
! where
! switchLevel :: State -> IO ()
! switchLevel state@(State {gamelevel=gamelevel}) = do
! set w [off keyboard]
! set tm [interval =: 80, on command =: betweenLevels nrAnimationSteps (-1)]
! where
! betweenLevels :: Int -> Int -> IO ()
! betweenLevels animationStep step
! | animationStep<=1 = set tm [on command =: betweenLevels 2 1]
! | animationStep<=nrAnimationSteps = do
! drawInWindow UnBuffered w (drawAnimation animationStep step)
! set tm [on command =: betweenLevels (animationStep+step) step]
! | otherwise = do
! set tm [interval =: speed gamelevel, on command =: onTimer ref mnew mopts mplay mexit tm w]
! set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
! repaint w
- nextLife :: State -> IO ()
- nextLife state@(State {gamelevel=gamelevel,foodsupply=foodsupply,points=points,best=best,worm=worm,lives=lives})
- | lives>0 =
- let
- deadWorm :: Worm -> IO ()
- deadWorm (segment:rest) = do
- drawInWindow UnBuffered w (eraseSegment segment)
- set tm [on command =: deadWorm rest]
- deadWorm [] = do
- set tm [interval =: speed gamelevel, on command =: onTimer ref mnew mopts mplay mexit tm w]
- set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
- repaint w
- in do
- set w [off keyboard]
- set tm [interval =: 100, on command =: deadWorm worm]
- | itsAHighScore nrOfHighScores points best = do
- onHalt ref mnew mopts mplay mexit tm w
- refName <- newIORef ""
- dlg <- dialog [] Nothing
- lbl1 <- label [title =: "Game Over with a new high score!"] dlg
- lbl2 <- label [title =: "Your name:"] dlg
- e <- entry [] dlg
- let onOK refName dlg e = do
- get e title >>= writeIORef refName
- destroyWidget dlg
- btnOK <- button [title =: "OK", on command =: onOK refName dlg e] dlg
- set dlg [layout =: padding 5 (lbl1 ^^^ padding 15 (lbl2 ^^^ hfill e) ^^^ hcenter btnOK)]
- runDialog dlg
- name <- readIORef refName
- when (name /= "") $ do
- let best' = addScore nrOfHighScores (HiScore name points) best
- writeHiScores hiScoresFile best'
- modifyIORef ref (\state -> state{best=best'})
- | otherwise = do
- onHalt ref mnew mopts mplay mexit tm w
- messageAlert "Game Over, no high score."
-
onKeyboard ref mnew mopts mplay mexit tm w (KeyDown key _) = do
! modifyIORef ref (\state@(State {dir=dir}) -> case key of
! KeyArrowUp _ | dir == West || dir == East -> state{dir=North}
! KeyArrowDown _ | dir == West || dir == East -> state{dir=South}
! KeyArrowLeft _ | dir == North || dir == South -> state{dir=West}
! KeyArrowRight _ | dir == North || dir == South -> state{dir=East}
! _ -> state)
! onTimer ref mnew mopts mplay mexit tm w
onKeyboard ref mnew mopts mplay mexit tm w _ = return ()
-
- {- state <- openWindow undefined window state
- state <- openMenu undefined filemenu state
- state <- openMenu undefined optionsmenu state
- state <- openTimer undefined timer state
- state <- initFoodSupply (mkStdGen 0) state
- state <- initWindowPicture state
- return state
- where
- [fileID,playID,haltID,quitID,levelID,contID,windowID,timerID] = ids
-
- initFoodSupply :: StdGen -> State -> GUI State State
- initFoodSupply seed state@(State {worm=worm,gamelevel=gamelevel}) = do
- let (food,foods) = newFood worm gamelevel (randoms seed)
- return state{food=food,foodsupply=foods}
-
- initWindowPicture :: State -> GUI State State
- initWindowPicture state = do
- drawInWindow windowID setPenFontSize
- return state
- where
- setPenFontSize :: Draw ()
- setPenFontSize = do
- font <- getPenFont
- setPenFont font{fontSize=wormFontSize}
-
- filemenu = Menu "File"
- ( MenuItem "Play" [MenuId playID,MenuShortKey 'r',MenuFunction (noLS play)]
- :+: MenuItem "Halt" [MenuId haltID,MenuShortKey '.',MenuFunction (noLS halt),MenuSelectState Unable]
- :+: MenuSeparator []
- :+: MenuItem "About Worm..." [MenuFunction (noLS (showAbout "Worm" helpFile))]
- :+: MenuItem "Help" [MenuFunction (noLS (showHelp helpFile))]
- :+: MenuSeparator []
- :+: MenuItem "Quit" [MenuId quitID,MenuShortKey 'q',MenuFunction (noLS quit)]
- ) [MenuId fileID]
- optionsmenu = Menu "Options"
- ( RadioMenu
- [ ("Slow" ,Nothing,Just '1',noLS (setSpeed easySpeed) )
- , ("Medium",Nothing,Just '2',noLS (setSpeed mediumSpeed))
- , ("Fast" ,Nothing,Just '3',noLS (setSpeed hardSpeed) )
- ] 1 []
- :+: MenuSeparator []
- :+: MenuItem "High Scores" [MenuShortKey 'h',MenuFunction (noLS showBest)]
- )
- [ MenuId levelID
- ]
- window = Window "Worm" NilLS
- [ WindowId windowID
- , WindowClose (noLS quit)
- , WindowKeyboard keyFilter Unable (noLS1 makeTurn)
- , WindowPen [PenBack wormBackGroundColour]
- , WindowViewDomain zero{corner2=Point2{x=488,y=303}}
- , WindowLook True (updateWindow (initState best))
- ]
- timer = Timer easySpeed NilLS [TimerId timerID, TimerSelectState Unable, TimerFunction (noLS1 oneStep)]
-
- -- The update function for the playfield window.
- updateWindow :: State -> SelectState -> UpdateState -> Draw ()
- updateWindow (State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}) _ (UpdateState {updArea=updArea}) = do
- mapM_ unfill updArea
- drawGame gamelevel food points worm lives
-
- -- The function for the Play command.
- play :: State -> GUI State State
- play state = do
- disableMenus [levelID]
- disableMenuElements [playID,quitID]
- enableMenuElements [haltID]
- setTimerInterval timerID (speed (gamelevel state))
- enableWindowKeyboard windowID
- enableTimer timerID
- drawInWindow windowID (drawGame initlevel newfood initpoints initworm initlives)
- setWindowCursor windowID HiddenCursor
- return initstate
- where
- initlevel = initLevel (fix (gamelevel state))
- initworm = newWorm initlevel
- (newfood,foods1) = newFood initworm initlevel (foodsupply state)
- initpoints = 0
- initlives = nrOfWorms
- initstate = state
- { gamelevel = initlevel
- , food = newfood
- , foodsupply = foods1
- , grow = 0
- , points = initpoints
- , dir = rightKey
- , worm = initworm
- , lives = initlives
- }
-
- -- The functions for the Halt/Continue command(s).
- halt :: State -> GUI State State
- halt state = do
- setWindowCursor windowID StandardCursor
- disableWindowKeyboard windowID
- disableTimer timerID
- enableMenuElements [quitID]
- closeMenuElements fileID [haltID]
- openMenuElements fileID 1 undefined continue
- return state
- where
- continue = MenuItem "Continue" [MenuId contID, MenuShortKey '.', MenuFunction (noLS contf)]
-
- contf :: State -> GUI State State
- contf state = do
- enableWindowKeyboard windowID
- enableTimer timerID
- setWindowCursor windowID HiddenCursor
- disableMenuElements [quitID]
- closeMenuElements fileID [contID]
- openMenuElements fileID 1 undefined hlt
- return state
- where
- hlt = MenuItem "Halt" [MenuId haltID, MenuShortKey '.', MenuFunction (noLS halt)]
-
- -- The function for the Quit command: stop the program and write the high scores to file.
- quit :: State -> GUI State State
- quit state@(State {best=best}) = do
- state <- closeProcess state
- liftIO (writeHiScores hiScoresFile best)
- return state
-
- -- Set a new speed (called when one of the Options commands is chosen).
- setSpeed :: Int -> State -> GUI State State
- setSpeed fix state =
- return state{gamelevel=(gamelevel state){fix=fix,speed=fix}}
-
- -- Show the high scores.
- showBest :: State -> GUI State State
- showBest state@(State {best=best}) = showHiScores "Worm High Scores:" best state
-
- -- The MakeTurn function is called when an arrow key is pressed.
- keyFilter :: KeyboardState -> Bool
- keyFilter (SpecialKey key (KeyDown _) _) = key `elem` [downKey,leftKey,rightKey,upKey]
- keyFilter _ = False
-
- makeTurn :: KeyboardState -> State -> GUI State State
- makeTurn (SpecialKey key _ _) state@(State {dir=dir})
- | (dir==upKey || dir==downKey) && (key==leftKey || key==rightKey) = oneStep 1 state{dir=key}
- | (dir==leftKey || dir==rightKey) && (key==upKey || key==downKey ) = oneStep 1 state{dir=key}
- | otherwise = return state
-
- -- The function for the Timer device: do one step of the worm game.
- oneStep :: NrOfIntervals -> State -> GUI State State
- oneStep _ state@(State {gamelevel=gamelevel,food=food,foodsupply=foodsupply,grow=grow,points=points,dir=dir,worm=worm,best=best,lives=lives})
- | newlevel/=curlevel = switchLevel gamelevel foodsupply points2 points best lives state
- | otherwise =
- let
- state1 = state{food=food1,foodsupply=foods1,grow=grow1,points=points2,worm=worm1}
- in
- if collide
- then nextLife state1
- else do
- drawInWindow windowID (drawStep scored food food1 points2 (head worm) hd tl)
- return state1
- where
- (hd,tl,worm1) = stepWorm dir grow worm
- scored = hd==pos food
- collide = collision gamelevel worm hd
- (food1,foods1) = if scored then (newFood worm1 gamelevel foodsupply) else (food,foodsupply)
- grow1 = if scored then (grow+((value food)*3)`div`2) else (max 0 (grow-1))
- points1 = if scored then points+(value food)*(length worm1) `div` 2 else points
- points2 = if collide then max 0 (points1-100) else points1
- curlevel = points `div` pointsPerLevel
- newlevel = points2 `div` pointsPerLevel
-
- collision :: Level -> Worm -> Segment -> Bool
- collision level worm head
- = (not (inRectangle head (Rectangle {corner1=Point2{x=1,y=1},corner2=Point2{x=sizeX,y=sizeY}})))
- || (any (inRectangle head) (obstacles level))
- || (head `elem` worm)
- where
- inRectangle :: Point2 -> Obstacle -> Bool
- inRectangle (Point2 x y) (Rectangle (Point2 lx ty) (Point2 rx by)) =
- x>=lx && x<=rx && y>=ty && y<=by
-
- stepWorm :: SpecialKey -> Grow -> Worm -> (Segment,Segment,Worm)
- stepWorm dir 0 worm = (hd,tl,(hd:worm1))
- where
- (tl,worm1) = getAndRemoveLast worm
- hd = newHead dir (head worm)
-
- getAndRemoveLast :: [x] -> (x,[x])
- getAndRemoveLast [x] = (x,[])
- getAndRemoveLast (x:xs) = (x1,x:xs1)
- where
- (x1,xs1) = getAndRemoveLast xs
- stepWorm dir _ worm = (hd,zero,hd:worm)
- where
- hd = newHead dir (head worm)
-
- newHead :: SpecialKey -> Segment -> Segment
- newHead key segment@(Point2 x y)
- | key==upKey = segment{y=y-1}
- | key==downKey = segment{y=y+1}
- | key==leftKey = segment{x=x-1}
- | key==rightKey = segment{x=x+1}
- | otherwise = error ("newHead applied to unknown SpecialKey: "++show key)
-
- switchLevel :: Level -> [Food] -> Points -> Points -> HiScores -> Lives -> State -> GUI State State
- switchLevel curlevel foods newPoints oldPoints high lives state = do
- id <- openId
- nextLevelAnimation id newstate
- where
- newlevel = (if newPoints>oldPoints then increaseLevel else decreaseLevel) curlevel
- initworm = newWorm newlevel
- (newfood,foods1) = newFood initworm newlevel foods
- newstate = State
- { gamelevel = newlevel
- , food = newfood
- , foodsupply = foods1
- , grow = 0
- , points = newPoints
- , dir = rightKey
- , worm = initworm
- , best = high
- , lives = if newPoints>oldPoints then lives+1 else lives-1
- }
-
- nextLevelAnimation :: Id -> State -> GUI State State
- nextLevelAnimation id state = do
- disableWindowKeyboard windowID
- disableTimer timerID
- state <- openTimer (nrAnimationSteps,-1) (Timer (ticksPerSecond `div` 30) NilLS
- [ TimerId id
- , TimerFunction betweenLevels
- ]) state
- return state
- where
- nrAnimationSteps= 40
-
- betweenLevels :: NrOfIntervals -> GUIFun (Int,Int) State
- betweenLevels _ ((animationStep,step), state@(State{gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives}))
- | animationStep<=1 = return ((2,1),state)
- | animationStep<=nrAnimationSteps = do
- drawInWindow windowID (drawAnimation animationStep step)
- return ((animationStep+step,step),state)
- | otherwise = do
- drawInWindow windowID (drawGame gamelevel food points worm lives)
- enableTimer timerID
- closeTimer id
- enableWindowKeyboard windowID
- return ((animationStep,step),state)
-
- nextLife :: State -> GUI State State
- nextLife state@(State {gamelevel=gamelevel,foodsupply=foodsupply,points=points,best=best,worm=worm,lives=lives})
- | lives>0 =
- let
- (newfood,foods1)= newFood newworm gamelevel foodsupply
- newworm = newWorm gamelevel
-
- deadWormAlert :: Id -> Worm -> State -> GUI State State
- deadWormAlert id worm state = do
- disableTimer timerID
- disableWindowKeyboard windowID
- state <- openTimer worm (Timer (ticksPerSecond `div` 30) NilLS [TimerId id,TimerFunction deadWorm]) state
- return state
- where
- deadWorm :: NrOfIntervals -> GUIFun Worm State
- deadWorm _ (segment:rest,state) = do
- drawInWindow windowID (eraseSegment segment)
- return (rest,state)
- deadWorm _ (segments,state@(State {gamelevel=gamelevel,food=food,points=points,worm=worm,lives=lives})) = do
- drawInWindow windowID (drawGame gamelevel food points worm lives)
- enableTimer timerID
- closeTimer id
- enableWindowKeyboard windowID
- return (segments,state)
- in do
- id <- openId
- deadWormAlert id worm state{ food = newfood
- , foodsupply = foods1
- , grow = 0
- , dir = rightKey
- , worm = newworm
- , lives = lives-1
- }
- | otherwise =
- let
- dialog [overId,okId,editId]
- = Dialog "Game Over"
- ( TextControl "Game Over with a new high score!" [ControlPos (Left,zero)]
- :+: TextControl "Your name:" [ControlPos (Left,zero)]
- :+: EditControl "" (PixelWidth (hmm 45.0)) 1 [ControlId editId]
- :+: ButtonControl "OK" [ControlPos (Center,zero),ControlFunction (noLS overOK)]
- )
- [ WindowId overId
- , WindowOk okId
- , WindowItemSpace (hmm 6.0) (vmm 6.0)
- ]
- where
- overOK :: State -> GUI State State
- overOK state = do
- (_, mb_name) <- getControlText editId
- state <- (case mb_name of
- Nothing -> error "OK button could not retrieved."
- Just name -> addscore name state)
- closeWindow overId state
- where
- addscore :: String -> State -> GUI State State
- addscore name state@(State {points=points,best=curBest})
- | null name = return state
- | otherwise = do
- let newBest = addScore nrOfHiScores (HiScore{name=name,score=points}) curBest
- return state{best=newBest}
- in do
- enableMenus [levelID]
- enableMenuElements [playID,quitID]
- disableMenuElements [haltID]
- disableTimer timerID
- disableWindowKeyboard windowID
- setWindowCursor windowID StandardCursor
- (if (itsAHighScore nrOfHiScores points best)
- then do
- ids <- openIds 3
- openModalDialog undefined (dialog ids) state
- return state
- else return state)
- | otherwise = do
- openModalDialog undefined (Notice ["Game Over, no high score."] (NoticeButton "OK" return) []) state
- return state
- -}
\ No newline at end of file
--- 10,216 ----
! -- GUI constants.
hiScoresFile = "wormhi"
nrOfHiScores = 8
! -- Start of the program.
main :: IO ()
main = do
! hiscores <- readHiScores hiScoresFile
! start "Worm" "1.0" SDI [] (startWorm hiscores)
startWorm :: HiScores -> IO ()
startWorm best = do
! ref <- newIORef (initState best)
! -- File menu
! mfile <- menu [title =: "File"] mainMenu
! mnew <- menuitem [title =: "New", accel =: KeyChar '\^N'] mfile
! mplay <- menuitem [title =: "Play", accel =: KeyChar '\^P'] mfile
! menuline mfile
! mexit <- menuitem [title =: "Exit", on command =: halt] mfile
!
! -- Options menu
! mopts <- menu [title =: "Options"] mainMenu
! mspeed <- menuRadioGroup [] mopts
! menuRadioItem [title =: "Slow"
! ,on command =: onSetSpeed ref easySpeed
! ] mspeed
! menuRadioItem [title =: "Medium"
! , on command =: onSetSpeed ref mediumSpeed
! ] mspeed
! menuRadioItem [title =: "Fast"
! ,on command =: onSetSpeed ref hardSpeed
! ] mspeed
! menuline mopts
! menuitem [title =: "High Scores"
! ,accel =: KeyChar '\^S'
! ,on command =: onShowBest ref
! ] mopts
!
! -- Help menu
! mhelp <- menu [title =: "Help"] mainMenu
! menuitem [title =: "About Worm..."
! ,on command =: onAbout
! ] mhelp
!
! -- Main window
! w <- window [ bgcolor =: wormBackGroundColour
! , bkDrawMode =: True
! , view =: Size 488 303
! , on paint =: onPaint ref
! , on dismiss =: halt
! , resizeable =: False
! ]
!
! -- Timer
! tm <- timer [enabled =: False]
! set tm [on command =: onTimer ref mnew mopts mplay mexit tm w]
!
! set mplay [on command =: onPlay ref mnew mopts mplay mexit tm w]
! set mnew [on command =: onNew ref w]
onPaint ref can _ _ = do
! state <- readIORef ref
! drawGame state can
onNew ref w = do
! modifyIORef ref (initState . best)
! repaint w
onPlay ref mnew mopts mplay mexit tm w = do
! state <- readIORef ref
! set mplay [title =: "Stop"
! ,on command =: onStop ref mnew mopts mplay mexit tm w
! ]
! set mnew [enabled =: False]
! set mopts [enabled =: False]
! set mexit [enabled =: False]
! set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
! set tm [enabled =: True
! ,interval =: speed (gamelevel state)
! ]
onStop ref mnew mopts mplay mexit tm w = do
! set mplay [title =: "Play"
! ,on command =: onPlay ref mnew mopts mplay mexit tm w
! ]
! set mnew [enabled =: True]
! set mopts [enabled =: True]
! set mexit [enabled =: True]
! set w [off keyboard]
! set tm [enabled =: False]
!
onHalt ref mnew mopts mplay mexit tm w = do
! onStop ref mnew mopts mplay mexit tm w
! onNew ref w
!
onAbout = do
! logo <- readBitmap "logo.bmp" []
! runAboutDialog "Worm" "1.0"
! "(C) Krasimir Angelov, 2003"
! "The Worm is an example program
! freely distributed with HToolkit"
! [] [] [] logo Nothing
!
onSetSpeed ref speed =
! modifyIORef ref (\state -> state{gamelevel=
! (gamelevel state){fix=speed,speed=speed}})
onShowBest ref = do
! state <- readIORef ref
! showHiScores "Worm High Scores:" (best state)
onTimer ref mnew mopts mplay mexit tm w = do
! state <- readIORef ref
! let (event,state1) = stepGame state
! writeIORef ref state1
! case event of
! IncreaseLevel -> switchLevel state1
! DecreaseLevel -> switchLevel state1
! Collide -> nextLife state
! _ -> drawInWindow UnBuffered w (drawStep state state1)
! where
! switchLevel :: State -> IO ()
! switchLevel state@(State {gamelevel=gamelevel}) = do
! set w [off keyboard]
! set tm [interval =: 80
! ,on command =: betweenLevels nrAnimationSteps (-1)
! ]
! where
! betweenLevels :: Int -> Int -> IO ()
! betweenLevels animationStep step
! | animationStep<=1 =
! set tm [on command =: betweenLevels 2 1]
! | animationStep<=nrAnimationSteps = do
! drawInWindow UnBuffered w
! (drawAnimation animationStep step)
! set tm [on command =: betweenLevels (animationStep+step) step]
! | otherwise = do
! set tm [interval =: speed gamelevel
! ,on command =: onTimer ref mnew mopts mplay mexit tm w
! ]
! set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
! repaint w
!
! nextLife :: State -> IO ()
! nextLife state@(State {gamelevel=gamelevel
! ,foodsupply=foodsupply
! ,points=points
! ,best=best
! ,worm=worm
! ,lives=lives
! })
! | lives>0 =
! let
! deadWorm :: Worm -> IO ()
! deadWorm (segment:rest) = do
! drawInWindow UnBuffered w (eraseSegment segment)
! set tm [on command =: deadWorm rest]
! deadWorm [] = do
! set tm [interval =: speed gamelevel
! ,on command =: onTimer ref mnew mopts mplay mexit tm w
! ]
! set w [on keyboard =: onKeyboard ref mnew mopts mplay mexit tm w]
! repaint w
! in do
! set w [off keyboard]
! set tm [interval =: 100
! ,on command =: deadWorm worm
! ]
! | itsAHighScore nrOfHighScores points best = do
! onHalt ref mnew mopts mplay mexit tm w
! refName <- newIORef ""
! dlg <- dialog [] Nothing
! lbl1 <- label [title =: "Game Over with a new high score!"] dlg
! lbl2 <- label [title =: "Your name:"] dlg
! e <- entry [] dlg
! let onOK refName dlg e = do
! get e title >>= writeIORef refName
! destroyWidget dlg
! btnOK <- button [title =: "OK"
! ,on command =: onOK refName dlg e
! ] dlg
! set dlg [layout =: padding 5
! (lbl1 ^^^ padding 15 (lbl2 ^^^ hfill e) ^^^ hcenter btnOK)]
! runDialog dlg
! name <- readIORef refName
! when (name /= "") $ do
! let best' = addScore nrOfHighScores (HiScore name points) best
! writeHiScores hiScoresFile best'
! modifyIORef ref (\state -> state{best=best'})
! | otherwise = do
! onHalt ref mnew mopts mplay mexit tm w
! messageAlert "Game Over, no high score."
onKeyboard ref mnew mopts mplay mexit tm w (KeyDown key _) = do
! modifyIORef ref (\state@(State {dir=dir}) -> case key of
! KeyArrowUp _ | dir == West || dir == East -> state{dir=North}
! KeyArrowDown _ | dir == West || dir == East -> state{dir=South}
! KeyArrowLeft _ | dir == North || dir == South -> state{dir=West}
! KeyArrowRight _ | dir == North || dir == South -> state{dir=East}
! _ -> state)
! onTimer ref mnew mopts mplay mexit tm w
onKeyboard ref mnew mopts mplay mexit tm w _ = return ()
Index: WormShow.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/worm/WormShow.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** WormShow.hs 7 Jun 2003 18:30:05 -0000 1.1
--- WormShow.hs 21 Jun 2003 10:04:29 -0000 1.2
***************
*** 1,10 ****
module WormShow
! ( drawGame
! , drawStep
! , drawAnimation
! , eraseSegment
! , wormBackGroundColour
! , nrAnimationSteps
! ) where
import Graphics.UI.GIO
--- 1,10 ----
module WormShow
! ( drawGame
! , drawStep
! , drawAnimation
! , eraseSegment
! , wormBackGroundColour
! , nrAnimationSteps
! ) where
import Graphics.UI.GIO
***************
*** 13,117 ****
-- The drawing constants.
! wormBackGroundColour = lightyellow
! wormFontSize = 12 :: Int
! pointsPos = Point 72 15
! lifesPos = Point 255 5
! levelPos = Point 465 15
! cornerX = 15 :: Int
! cornerY = 23 :: Int
! segSize = 4 :: Int
! cellSize = 10 :: Int
! nrAnimationSteps = 40 :: Int
-- Draw the game.
drawGame :: State -> Canvas -> IO ()
! drawGame (State {gamelevel=Level {level=level,obstacles=obstacles},food=food,points=points,worm=worm,lives=lives}) can = do
! drawBorders can
! drawObstacles obstacles can
! drawPoints points can
! drawWorm worm can
! drawFood food can
! drawLevel level can
! drawLives lives can
! where
! drawObstacles :: [Obstacle] -> Canvas -> IO ()
! drawObstacles [] can = return ()
! drawObstacles obstacles can = do
! setCanvasPen can [color =: purple]
! mapM_ drawObstacle obstacles
! setCanvasPen can [color =: black]
! where
! drawObstacle :: Obstacle -> IO ()
! drawObstacle (Rect ltx lty rbx rby) =
! fillRect (Rect lx ty rx by) can
! where
! lx = cornerX+cellSize*ltx-2
! ty = cornerY+cellSize*lty-2
! rx = cornerX+cellSize*rbx+2
! by = cornerY+cellSize*rby+2
!
! drawPoints :: Points -> Canvas -> IO ()
! drawPoints points can = do
! setCanvasPen can [color =: magenta]
! drawString pointsPos{px=(px pointsPos) - 57} "Points: " can
! setCanvasPen can [color =: black]
! drawString pointsPos (show points) can
! drawWorm :: Worm -> Canvas -> IO ()
! drawWorm [] can = return ()
! drawWorm (head:rest) can = do
! mapM_ (\s -> drawSegment red s can) rest
! drawSegment lightgreen head can
! setCanvasPen can [color =: black]
! drawLevel :: Int -> Canvas -> IO ()
! drawLevel level can = do
! setCanvasPen can [color =: magenta]
! drawString levelPos{px=px levelPos-50} "Level: " can
! setCanvasPen can [color =: black]
! drawString levelPos (show level) can
! drawLives :: Lives -> Canvas -> IO ()
! drawLives lives can
! | lives /= 0 = drawLittleWorms lives can
! | otherwise = do
! setCanvasPen can [color =: magenta]
! drawString (Point (lx-63) (ly+10)) "No more worms!" can
! setCanvasPen can [color =: black]
! where
! Point lx ly = lifesPos
! drawLittleWorms :: Lives -> Canvas -> IO ()
! drawLittleWorms lives can
! | lives>0 = do
! drawLittleWorm lives can
! drawLittleWorms (lives-1) can
! | otherwise = do
! setCanvasPen can [color =: magenta]
! drawString (Point (lx-63) (ly+10)) "Worms:" can
! setCanvasPen can [color =: black]
! where
! drawLittleWorm :: Int -> Canvas -> IO ()
! drawLittleWorm n can = do
! setCanvasPen can [thickness=:5, color =: red]
! drawLine (Point x y) (Point (x+9) y) can
! setCanvasPen can [color =: lightgreen]
! drawLine (Point (x+9) y) (Point (x+14) y) can
! setCanvasPen can [thickness=:1, color =: black]
! where
! x = lx+20*((n-1) `div` 2)
! y = ly+ 7*((n-1) `mod` 2)
drawBorders :: Canvas -> IO ()
drawBorders can = do
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect (cornerX-3) (cornerY-3) (cornerX+sizeX*cellSize+11) (cornerY+sizeY*cellSize+11)) can
! setCanvasPen can [thickness=:1]
drawSegment :: Color -> Segment -> Canvas -> IO ()
drawSegment c (Point x y) can = do
! setCanvasPen can [color=:c]
! fillCircle (Point (cornerX+cellSize*x) (cornerY+cellSize*y)) segSize can
eraseSegment :: Segment -> Canvas -> IO ()
--- 13,122 ----
-- The drawing constants.
! wormBackGroundColour = lightyellow
! wormFontSize = 12 :: Int
! pointsPos = Point 72 15
! lifesPos = Point 255 5
! levelPos = Point 465 15
! cornerX = 15 :: Int
! cornerY = 23 :: Int
! segSize = 4 :: Int
! cellSize = 10 :: Int
! nrAnimationSteps = 40 :: Int
-- Draw the game.
drawGame :: State -> Canvas -> IO ()
! drawGame (State {gamelevel=Level {level=level,obstacles=obstacles}
! ,food=food
! ,points=points
! ,worm=worm
! ,lives=lives
! }) can = do
! drawBorders can
! drawObstacles obstacles can
! drawPoints points can
! drawWorm worm can
! drawFood food can
! drawLevel level can
! drawLives lives can
! where
! drawObstacles :: [Obstacle] -> Canvas -> IO ()
! drawObstacles [] can = return ()
! drawObstacles obstacles can = do
! setCanvasPen can [color =: purple]
! mapM_ drawObstacle obstacles
! setCanvasPen can [color =: black]
! where
! drawObstacle :: Obstacle -> IO ()
! drawObstacle (Rect ltx lty rbx rby) =
! fillRect (Rect lx ty rx by) can
! where
! lx = cornerX+cellSize*ltx-2
! ty = cornerY+cellSize*lty-2
! rx = cornerX+cellSize*rbx+2
! by = cornerY+cellSize*rby+2
! drawPoints :: Points -> Canvas -> IO ()
! drawPoints points can = do
! setCanvasPen can [color =: magenta]
! drawString pointsPos{px=(px pointsPos) - 57} "Points: " can
! setCanvasPen can [color =: black]
! drawString pointsPos (show points) can
! drawWorm :: Worm -> Canvas -> IO ()
! drawWorm [] can = return ()
! drawWorm (head:rest) can = do
! mapM_ (\s -> drawSegment red s can) rest
! drawSegment lightgreen head can
! setCanvasPen can [color =: black]
! drawLevel :: Int -> Canvas -> IO ()
! drawLevel level can = do
! setCanvasPen can [color =: magenta]
! drawString levelPos{px=px levelPos-50} "Level: " can
! setCanvasPen can [color =: black]
! drawString levelPos (show level) can
! drawLives :: Lives -> Canvas -> IO ()
! drawLives lives can
! | lives /= 0 = drawLittleWorms lives can
! | otherwise = do
! setCanvasPen can [color =: magenta]
! drawString (Point (lx-63) (ly+10)) "No more worms!" can
! setCanvasPen can [color =: black]
! where
! Point lx ly = lifesPos
+ drawLittleWorms :: Lives -> Canvas -> IO ()
+ drawLittleWorms lives can
+ | lives>0 = do
+ drawLittleWorm lives can
+ drawLittleWorms (lives-1) can
+ | otherwise = do
+ setCanvasPen can [color =: magenta]
+ drawString (Point (lx-63) (ly+10)) "Worms:" can
+ setCanvasPen can [color =: black]
+ where
+ drawLittleWorm :: Int -> Canvas -> IO ()
+ drawLittleWorm n can = do
+ setCanvasPen can [thickness=:5, color =: red]
+ drawLine (Point x y) (Point (x+9) y) can
+ setCanvasPen can [color =: lightgreen]
+ drawLine (Point (x+9) y) (Point (x+14) y) can
+ setCanvasPen can [thickness=:1, color =: black]
+ where
+ x = lx+20*((n-1) `div` 2)
+ y = ly+ 7*((n-1) `mod` 2)
drawBorders :: Canvas -> IO ()
drawBorders can = do
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect (cornerX-3) (cornerY-3)
! (cornerX+sizeX*cellSize+11) (cornerY+sizeY*cellSize+11)) can
! setCanvasPen can [thickness=:1]
drawSegment :: Color -> Segment -> Canvas -> IO ()
drawSegment c (Point x y) can = do
! setCanvasPen can [color=:c]
! fillCircle (Point (cornerX+cellSize*x) (cornerY+cellSize*y)) segSize can
eraseSegment :: Segment -> Canvas -> IO ()
***************
*** 120,150 ****
drawFood :: Food -> Canvas -> IO ()
drawFood (Food _ (Point x y)) can = do
! setCanvasPen can [color=:magenta]
! fillRect (Rect x1 y1 (x1+6) (y1+6)) can
! setCanvasPen can [color=:black]
! where
! x1 = cornerX+cellSize*x-3
! y1 = cornerY+cellSize*y-3
!
eraseFood :: Food -> Canvas -> IO ()
eraseFood (Food _ (Point x y)) can = do
! setCanvasPen can [color=:yellow]
! fillRect (Rect x1 y1 (x1+6) (y1+6)) can
! setCanvasPen can [color=:black]
! where
! x1 = cornerX+cellSize*x-3
! y1 = cornerY+cellSize*y-3
!
-- Show a step of the worm.
drawStep :: State -> State -> Canvas -> IO ()
! drawStep (State{food=oldfood,worm=oldworm}) (State{food=newfood,worm=newworm,points=points}) can = do
! eraseFood oldfood can
! drawFood newfood can
! drawString pointsPos (show points) can
! drawSegment red (head oldworm) can
! drawSegment lightgreen (head newworm) can
! when (length oldworm == length newworm) (drawSegment wormBackGroundColour (last oldworm) can)
! setCanvasPen can [color=:black]
--- 125,158 ----
drawFood :: Food -> Canvas -> IO ()
drawFood (Food _ (Point x y)) can = do
! setCanvasPen can [color=:magenta]
! fillRect (Rect x1 y1 (x1+6) (y1+6)) can
! setCanvasPen can [color=:black]
! where
! x1 = cornerX+cellSize*x-3
! y1 = cornerY+cellSize*y-3
!
eraseFood :: Food -> Canvas -> IO ()
eraseFood (Food _ (Point x y)) can = do
! setCanvasPen can [color=:yellow]
! fillRect (Rect x1 y1 (x1+6) (y1+6)) can
! setCanvasPen can [color=:black]
! where
! x1 = cornerX+cellSize*x-3
! y1 = cornerY+cellSize*y-3
!
-- Show a step of the worm.
drawStep :: State -> State -> Canvas -> IO ()
! drawStep (State{food=oldfood,worm=oldworm}) (State{food=newfood
! ,worm=newworm
! ,points=points}) can = do
! eraseFood oldfood can
! drawFood newfood can
! drawString pointsPos (show points) can
! drawSegment red (head oldworm) can
! drawSegment lightgreen (head newworm) can
! when (length oldworm == length newworm)
! (drawSegment wormBackGroundColour (last oldworm) can)
! setCanvasPen can [color=:black]
***************
*** 153,175 ****
drawAnimation 40 1 can = drawBorders can
drawAnimation n step can
! | step<0 = do
! setCanvasPen can [color=:wormBackGroundColour]
! fillRect (Rect l b x y) can
! fillRect (Rect r t x y) can
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect l t r b) can
! | otherwise = do
! setCanvasPen can [color=:wormBackGroundColour]
! fillRect (Rect l b x (y-4)) can
! fillRect (Rect r t (x-4) y ) can
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect l t r b) can
! where
! l = cornerX-3
! t = cornerY-3
! r = l+w*n
! b = t+h*n
! x = r-step*w
! y = b-step*h
! w = (48+sizeX*cellSize) `div` nrAnimationSteps
! h = (48+sizeY*cellSize) `div` nrAnimationSteps
--- 161,183 ----
drawAnimation 40 1 can = drawBorders can
drawAnimation n step can
! | step<0 = do
! setCanvasPen can [color=:wormBackGroundColour]
! fillRect (Rect l b x y) can
! fillRect (Rect r t x y) can
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect l t r b) can
! | otherwise = do
! setCanvasPen can [color=:wormBackGroundColour]
! fillRect (Rect l b x (y-4)) can
! fillRect (Rect r t (x-4) y ) can
! setCanvasPen can [color=:black, thickness=:3]
! drawRect (Rect l t r b) can
! where
! l = cornerX-3
! t = cornerY-3
! r = l+w*n
! b = t+h*n
! x = r-step*w
! y = b-step*h
! w = (48+sizeX*cellSize) `div` nrAnimationSteps
! h = (48+sizeY*cellSize) `div` nrAnimationSteps
Index: WormState.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/worm/WormState.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** WormState.hs 7 Jun 2003 18:30:05 -0000 1.1
--- WormState.hs 21 Jun 2003 10:04:29 -0000 1.2
***************
*** 1,25 ****
module WormState
! ( -- data structures
! State(..)
! , Direction(..)
! , Level(..)
! , Food(..)
! , GameEvent(..)
!
! -- type aliases
! , Grow, Obstacle, Segment, Worm, Points, Lives
!
! -- constants
! , sizeX, sizeY
! , nrOfWorms, nrOfLevels, nrOfHighScores
! , pointsPerLevel
! , startLevel
! , easySpeed, mediumSpeed, hardSpeed
! , accelation
!
! , initState
! , stepGame
! ) where
import Graphics.UI.GIO
--- 1,25 ----
module WormState
! ( -- data structures
! State(..)
! , Direction(..)
! , Level(..)
! , Food(..)
! , GameEvent(..)
! -- type aliases
! , Grow, Obstacle, Segment, Worm, Points, Lives
!
! -- constants
! , sizeX, sizeY
!
! , nrOfWorms, nrOfLevels, nrOfHighScores
! , pointsPerLevel
! , startLevel
! , easySpeed, mediumSpeed, hardSpeed
! , accelation
!
! , initState
! , stepGame
! ) where
import Graphics.UI.GIO
***************
*** 28,263 ****
! -- The worm data types.
data State
= State
! { gamelevel :: Level
! , food :: Food
! , foodsupply :: [Food]
! , grow :: Grow
! , points :: Points
! , dir :: Direction
! , worm :: Worm
! , best :: HiScores
! , lives :: Lives
! }
data Direction
= North | West | East | South deriving Eq
data Level
= Level
! { fix :: Int
! , speed :: Int
! , level :: Int
! , obstacles :: [Obstacle]
! }
data Food = Food Int Point
! type Grow = Int
! type Obstacle = Rect
! type Segment = Point
! type Worm = [Segment]
! type Points = Int
! type Lives = Int
data GameEvent
= Scored | Collide | IncreaseLevel | DecreaseLevel | None deriving Show
! sizeX = 45 :: Int
! sizeY = 26 :: Int
! nrOfWorms = 4 :: Int
! nrOfLevels = 8 :: Int
! nrOfHighScores = 10 :: Int
! pointsPerLevel = 500 :: Int
! startLevel = 0 :: Int
! easySpeed = 300 :: Int
! mediumSpeed = 200 :: Int
! hardSpeed = 100 :: Int
! accelation = 100 :: Int
! -- Initial State.
initState :: HiScores -> State
initState best =
! State
! { gamelevel = initlevel
! , food = food
! , foodsupply = foodsupply
! , grow = 0
! , points = 0
! , dir = East
! , worm = initworm
! , best = best
! , lives = nrOfWorms
! }
! where
! (food,foodsupply) = newFood initworm initlevel (randoms (mkStdGen 0))
! initlevel = initLevel easySpeed
! initworm = newWorm initlevel
stepGame :: State -> (GameEvent,State)
stepGame state@(State { gamelevel=curlevel
! , food=food@(Food value pos)
! , foodsupply=foodsupply
! , grow=grow
! , points=points
! , dir=dir
! , worm=worm
! , best=best
! , lives=lives
! })
! | levelpoints > levelpoints1 =
! let
! newlevel = decreaseLevel curlevel
! (food1,foodsupply1) = newFood worm1 newlevel foodsupply
! initworm = newWorm newlevel
! in (DecreaseLevel,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=0
! , points=points1
! , worm=initworm
! , gamelevel=newlevel
! , dir=East
! , lives=lives-1
! })
! | levelpoints1 > levelpoints =
! let
! newlevel = increaseLevel curlevel
! (food1,foodsupply1) = newFood worm1 newlevel foodsupply
! initworm = newWorm newlevel
! in (IncreaseLevel,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=0
! , points=points1
! , worm=initworm
! , gamelevel=newlevel
! , dir=East
! , lives=lives+1
! })
! | scored =
! let
! (food1,foodsupply1) = newFood worm1 curlevel foodsupply
! in (Scored,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=grow1
! , points=points1
! , worm=worm1
! })
! | collide= (Collide,state
! { grow=0
! , points=points1
! , worm=newWorm curlevel
! , dir=East
! , lives=lives-1
! })
! | otherwise = (None,state
! { grow=grow1
! , worm=worm1
! })
! where
! levelpoints = points `div` pointsPerLevel
! levelpoints1 = points1 `div` pointsPerLevel
!
! hd = newHead dir (head worm)
!
! worm1 | grow == 0 = hd : init worm
! | otherwise = hd : worm
!
! grow1 | scored = grow+(value*3) `div` 2
! | otherwise = max 0 (grow-1)
!
! points1 | scored = points+value*(length worm1) `div` 2
! | collide = max 0 (points-100)
! | otherwise = points
!
! collide = (not (pointInRect hd (Rect 1 1 sizeX sizeY)))
! || (any (pointInRect hd) (obstacles curlevel))
! || (hd `elem` worm)
!
! scored = hd == pos
! newHead :: Direction -> Segment -> Segment
! newHead North (Point x y) = Point x (y-1)
! newHead South (Point x y) = Point x (y+1)
! newHead West (Point x y) = Point (x-1) y
! newHead East (Point x y) = Point (x+1) y
!
!
! -- Make a new initial worm.
newWorm :: Level -> Worm
newWorm Level{level=level} =
! [Point x y | x<-[5,4..1]]
! where
! y = startHeights !! (level `mod` nrOfLevels)
startHeights :: [Int]
startHeights = [13,5,13,13,13,1,1,14]
!
! -- Construct the next level.
initLevel :: Int -> Level
initLevel fix =
! Level {fix=fix,speed=fix,level=startLevel,obstacles=sampleObstacles!!startLevel}
decreaseLevel :: Level -> Level
decreaseLevel curlevel@(Level {speed=speed,level=level}) =
! let
! newLevel = level-1
! newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed+accelation else speed
! in
! curlevel
! { fix = newSpeed
! , speed = newSpeed
! , level = newLevel
! , obstacles = sampleObstacles !! (newLevel `mod` nrOfLevels)
! }
increaseLevel :: Level -> Level
increaseLevel curlevel@(Level {speed=speed,level=level}) =
! let
! newLevel = level+1
! newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed-accelation else speed
! in
! curlevel
! { fix = newSpeed
! , speed = newSpeed
! , level = newLevel
! , obstacles = sampleObstacles !! (newLevel `mod` nrOfLevels)
! }
sampleObstacles :: [[Obstacle]]
sampleObstacles =
! [ []
! , [Rect 12 11 34 16]
! , [Rect 12 1 34 3, Rect 12 24 34 26]
! , [Rect 7 7 38 9, Rect 7 17 38 19]
! , [Rect 1 1 18 10, Rect 28 17 45 26]
! , [Rect 14 3 15 24, Rect 30 3 31 24]
! , [Rect 3 13 43 14, Rect 22 3 24 24]
! , [Rect 3 3 20 12, Rect 26 15 43 24]
! ]
! -- Generate a food supply.
instance Random Food where
! random seed = (Food value pos, seed3)
! where
! (random1,seed1) = random seed
! (random2,seed2) = random seed1
! (random3,seed3) = random seed2
! foodx = (incMod random2 (sizeX-2))+1
! foody = (incMod random3 (sizeY-2))+1
! pos = Point foodx foody
! value = incMod random1 9
! incMod a b = (a `mod` b)+1
! randomR _ seed = random seed
! -- Think of some new random food.
newFood :: Worm -> Level -> [Food] -> (Food, [Food])
newFood worm level@(Level {obstacles=obstacles}) (food@(Food _ pos):foods)
! | pos `elem` worm || any (pointInRect pos) obstacles = newFood worm level foods
! | otherwise = (food, foods)
--- 28,259 ----
! -- The worm data types.
data State
= State
! { gamelevel :: Level
! , food :: Food
! , foodsupply :: [Food]
! , grow :: Grow
! , points :: Points
! , dir :: Direction
! , worm :: Worm
! , best :: HiScores
! , lives :: Lives
! }
data Direction
= North | West | East | South deriving Eq
data Level
= Level
! { fix :: Int
! , speed :: Int
! , level :: Int
! , obstacles :: [Obstacle]
! }
data Food = Food Int Point
! type Grow = Int
! type Obstacle = Rect
! type Segment = Point
! type Worm = [Segment]
! type Points = Int
! type Lives = Int
data GameEvent
= Scored | Collide | IncreaseLevel | DecreaseLevel | None deriving Show
! sizeX = 45 :: Int
! sizeY = 26 :: Int
! nrOfWorms = 4 :: Int
! nrOfLevels = 8 :: Int
! nrOfHighScores = 10 :: Int
! pointsPerLevel = 500 :: Int
! startLevel = 0 :: Int
! easySpeed = 300 :: Int
! mediumSpeed = 200 :: Int
! hardSpeed = 100 :: Int
! accelation = 100 :: Int
! -- Initial State.
initState :: HiScores -> State
initState best =
! State
! { gamelevel = initlevel
! , food = food
! , foodsupply = foodsupply
! , grow = 0
! , points = 0
! , dir = East
! , worm = initworm
! , best = best
! , lives = nrOfWorms
! }
! where
! (food,foodsupply) = newFood initworm initlevel (randoms (mkStdGen 0))
! initlevel = initLevel easySpeed
! initworm = newWorm initlevel
stepGame :: State -> (GameEvent,State)
stepGame state@(State { gamelevel=curlevel
! , food=food@(Food value pos)
! , foodsupply=foodsupply
! , grow=grow
! , points=points
! , dir=dir
! , worm=worm
! , best=best
! , lives=lives
! })
! | levelpoints > levelpoints1 =
! let
! newlevel = decreaseLevel curlevel
! (food1,foodsupply1) = newFood worm1 newlevel foodsupply
! initworm = newWorm newlevel
! in (DecreaseLevel,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=0
! , points=points1
! , worm=initworm
! , gamelevel=newlevel
! , dir=East
! , lives=lives-1
! })
! | levelpoints1 > levelpoints =
! let
! newlevel = increaseLevel curlevel
! (food1,foodsupply1) = newFood worm1 newlevel foodsupply
! initworm = newWorm newlevel
! in (IncreaseLevel,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=0
! , points=points1
! , worm=initworm
! , gamelevel=newlevel
! , dir=East
! , lives=lives+1
! })
! | scored =
! let
! (food1,foodsupply1) = newFood worm1 curlevel foodsupply
! in (Scored,state
! { food=food1
! , foodsupply=foodsupply1
! , grow=grow1
! , points=points1
! , worm=worm1
! })
! | collide= (Collide,state
! { grow=0
! , points=points1
! , worm=newWorm curlevel
! , dir=East
! , lives=lives-1
! })
! | otherwise = (None,state
! { grow=grow1
! , worm=worm1
! })
! where
! levelpoints = points `div` pointsPerLevel
! levelpoints1 = points1 `div` pointsPerLevel
! hd = newHead dir (head worm)
!
! worm1 | grow == 0 = hd : init worm
! | otherwise = hd : worm
!
! grow1 | scored = grow+(value*3) `div` 2
! | otherwise = max 0 (grow-1)
!
! points1 | scored = points+value*(length worm1) `div` 2
! | collide = max 0 (points-100)
! | otherwise = points
!
! collide = (not (pointInRect hd (Rect 1 1 sizeX sizeY)))
! || (any (pointInRect hd) (obstacles curlevel))
! || (hd `elem` worm)
!
! scored = hd == pos
!
! newHead :: Direction -> Segment -> Segment
! newHead North (Point x y) = Point x (y-1)
! newHead South (Point x y) = Point x (y+1)
! newHead West (Point x y) = Point (x-1) y
! newHead East (Point x y) = Point (x+1) y
!
! -- Make a new initial worm.
newWorm :: Level -> Worm
newWorm Level{level=level} =
! [Point x y | x<-[5,4..1]]
! where
! y = startHeights !! (level `mod` nrOfLevels)
startHeights :: [Int]
startHeights = [13,5,13,13,13,1,1,14]
! -- Construct the next level.
initLevel :: Int -> Level
initLevel fix =
! Level {fix=fix,speed=fix,level=startLevel,obstacles=sampleObstacles!!startLevel}
decreaseLevel :: Level -> Level
decreaseLevel curlevel@(Level {speed=speed,level=level}) =
! let
! newLevel = level-1
! newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed+accelation else speed
! in
! curlevel{ fix = newSpeed
! , speed = newSpeed
! , level = newLevel
! , obstacles = sampleObstacles !! (newLevel `mod` nrOfLevels)
! }
increaseLevel :: Level -> Level
increaseLevel curlevel@(Level {speed=speed,level=level}) =
! let
! newLevel = level+1
! newSpeed = if level `mod` nrOfLevels==0 && level/=0 then speed-accelation else speed
! in
! curlevel{ fix = newSpeed
! , speed = newSpeed
! , level = newLevel
! , obstacles = sampleObstacles !! (newLevel `mod` nrOfLevels)
! }
...
[truncated message content] |
|
From: <kr_...@us...> - 2003-06-17 17:05:42
|
Update of /cvsroot/htoolkit/gio/src/examples/simple
In directory sc8-pr-cvs1:/tmp/cvs-serv5894
Modified Files:
Calculator.hs SimpleMenu.hs
Log Message:
Update examples
Index: Calculator.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/Calculator.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Calculator.hs 2 Apr 2003 21:33:55 -0000 1.4
--- Calculator.hs 17 Jun 2003 17:05:39 -0000 1.5
***************
*** 6,16 ****
main
! = start SDI [] calculator
calculator
= do varst <- newVar (0,id)
! w <- window [title =: "calculator", resizeable =: True]
! display <- label [text =: "0"] w
! keys <- mapM (\c -> button [text =: [c], on command =: cmd varst display c] w) "123+456-789*C0=/"
set w [layout =: (pad 10 (hglue <<< display)) ^^^ grid (matrix 4 (map (hfix 50) keys))]
where
--- 6,16 ----
main
! = start "Calculator" "1.0" SDI [] calculator
calculator
= do varst <- newVar (0,id)
! w <- window []
! display <- label [title =: "0"] w
! keys <- mapM (\c -> button [title =: [c], on command =: cmd varst display c] w) "123+456-789*C0=/"
set w [layout =: (pad 10 (hglue <<< display)) ^^^ grid (matrix 4 (map (hfix 50) keys))]
where
***************
*** 21,25 ****
= do st <- getVar varst
let st' = calc st c
! set display [text =: show (fst st')]
setVar varst st'
--- 21,25 ----
= do st <- getVar varst
let st' = calc st c
! set display [title =: show (fst st')]
setVar varst st'
Index: SimpleMenu.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleMenu.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** SimpleMenu.hs 25 Apr 2003 06:56:28 -0000 1.5
--- SimpleMenu.hs 17 Jun 2003 17:05:39 -0000 1.6
***************
*** 4,9 ****
main
! = start SDI [] $
! do w <- window [title =: "Hello world", view =: sz 200 200]
bmpNew <- readBitmap "res/new.bmp" []
--- 4,9 ----
main
! = start "SimpleMenu" "1.0" SDI [] $
! do w <- window [view =: sz 200 200]
bmpNew <- readBitmap "res/new.bmp" []
|
|
From: <kr_...@us...> - 2003-06-08 21:11:51
|
Update of /cvsroot/htoolkit/port/src/include
In directory sc8-pr-cvs1:/tmp/cvs-serv31907/src/include
Modified Files:
Types.h
Log Message:
Added new context - theEraseGC. The new context is used for screen clearing.
Index: Types.h
===================================================================
RCS file: /cvsroot/htoolkit/port/src/include/Types.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Types.h 1 May 2003 19:35:36 -0000 1.10
--- Types.h 8 Jun 2003 21:11:48 -0000 1.11
***************
*** 104,108 ****
{
GdkDrawable *drawable;
! GdkGC *theDrawGC, *theFillGC, *theTextGC;
FontHandle theFont;
gint lineCustomCount;
--- 104,108 ----
{
GdkDrawable *drawable;
! GdkGC *theDrawGC, *theFillGC, *theEraseGC, *theTextGC;
FontHandle theFont;
gint lineCustomCount;
|
|
From: <kr_...@us...> - 2003-06-08 21:11:51
|
Update of /cvsroot/htoolkit/port/src/cbits/GTK
In directory sc8-pr-cvs1:/tmp/cvs-serv31907/src/cbits/GTK
Modified Files:
Canvas.c
Log Message:
Added new context - theEraseGC. The new context is used for screen clearing.
Index: Canvas.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/GTK/Canvas.c,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Canvas.c 10 Feb 2003 22:42:09 -0000 1.9
--- Canvas.c 8 Jun 2003 21:11:48 -0000 1.10
***************
*** 1,690 ****
! #include "Types.h"
! #include "Canvas.h"
! #include "Font.h"
! #include "Internals.h"
!
! int osMMtoVPixels(double mm)
! {
! return (int) ((mm*gdk_screen_height())/gdk_screen_height_mm());
! }
!
[...1346 lines suppressed...]
! } /* osDrawBitmap */
!
! void osSetFont (FontHandle font, CanvasHandle canvas)
! {
! canvas->theFont = font;
! } /* osSetFont */
!
! void osGetResolution(CanvasHandle canvas, int *xResP, int *yResP)
! {
! *xResP = gdk_screen_width();
! *yResP = gdk_screen_height();
! } /* osGetResolution */
!
! void osGetScaleFactor(CanvasHandle canvas, int *nh, int *dh, int *nv, int *dv)
! {
! *nh = 1;
! *dh = 1;
! *nv = 1;
! *dv = 1;
! } /* osGetScaleFactor */
|
|
From: <kr_...@us...> - 2003-06-08 19:42:46
|
Update of /cvsroot/htoolkit/gio
In directory sc8-pr-cvs1:/tmp/cvs-serv2042/gio
Modified Files:
configure makefile
Log Message:
Make HToolkit compatible with GHC-6.0
Index: configure
===================================================================
RCS file: /cvsroot/htoolkit/gio/configure,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** configure 26 Mar 2003 12:56:30 -0000 1.2
--- configure 8 Jun 2003 19:42:12 -0000 1.3
***************
*** 257,260 ****
--- 257,261 ----
echo "Package" > config/gio.pkg
echo " { name=\"gio\"" >> config/gio.pkg
+ echo " , auto=True" >> config/gio.pkg
echo " , import_dirs=[\"$curdir/imports\"]" >> config/gio.pkg
echo " , library_dirs=[\"$curdir/imports\"]" >> config/gio.pkg
Index: makefile
===================================================================
RCS file: /cvsroot/htoolkit/gio/makefile,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** makefile 30 Mar 2003 18:49:07 -0000 1.8
--- makefile 8 Jun 2003 19:42:12 -0000 1.9
***************
*** 135,139 ****
$(HOBJS): $(HOUTDIR)/%.o: %.hs
! $(HC) -o $@ -ohi $(subst .o,.hi,$@) -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) -i$(IMPORTSDIR) $(INCDIRS)
@# create dependency file
@$(HC) $< $(HC-OPTIONS) -M -optdep-f -optdep$(*F).d -i$(IMPORTSDIR)
--- 135,139 ----
$(HOBJS): $(HOUTDIR)/%.o: %.hs
! $(HC) -o $@ -package-name gio -ohi $(subst .o,.hi,$@) -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) -i$(IMPORTSDIR) $(INCDIRS)
@# create dependency file
@$(HC) $< $(HC-OPTIONS) -M -optdep-f -optdep$(*F).d -i$(IMPORTSDIR)
***************
*** 182,184 ****
webdoc: doc
# -cd doc; scp *.html *.css *.gif $(USERNAME)@sunshine.cs.uu.nl:~/pub-www/doc/gio; cd ..
! -cd doc; scp *.html *.css *.gif $(USERNAME)@shell.sourceforge.net:/home/groups/h/ht/htoolkit/htdocs/doc/gio; cd ..
\ No newline at end of file
--- 182,184 ----
webdoc: doc
# -cd doc; scp *.html *.css *.gif $(USERNAME)@sunshine.cs.uu.nl:~/pub-www/doc/gio; cd ..
! -cd doc; scp *.html *.css *.gif $(USERNAME)@shell.sourceforge.net:/home/groups/h/ht/htoolkit/htdocs/doc/gio; cd ..
|
|
From: <kr_...@us...> - 2003-06-08 19:42:18
|
Update of /cvsroot/htoolkit/port/src/Port In directory sc8-pr-cvs1:/tmp/cvs-serv2042/port/src/Port Modified Files: Bitmap.hs Canvas.hs Font.hs Handlers.hs Types.hs Window.hs Log Message: Make HToolkit compatible with GHC-6.0 Index: Bitmap.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Bitmap.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** Bitmap.hs 30 May 2003 21:46:47 -0000 1.6 --- Bitmap.hs 8 Jun 2003 19:42:14 -0000 1.7 *************** *** 34,40 **** import Graphics.UI.Port.Types ! import Control.Monad import System.IO.Error - import System.IO( bracket ) {----------------------------------------------------------------------------------------- --- 34,40 ---- import Graphics.UI.Port.Types ! import Control.Monad(when) ! import Control.Exception(bracket) import System.IO.Error {----------------------------------------------------------------------------------------- Index: Canvas.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Canvas.hs,v retrieving revision 1.14 retrieving revision 1.15 diff -C2 -d -r1.14 -r1.15 *** Canvas.hs 30 May 2003 21:46:47 -0000 1.14 --- Canvas.hs 8 Jun 2003 19:42:14 -0000 1.15 *************** *** 58,62 **** import Foreign.Marshal.Alloc import Foreign.Storable ! import System.IO( bracket ) import Graphics.UI.Port.Types --- 58,62 ---- import Foreign.Marshal.Alloc import Foreign.Storable ! import Control.Exception( bracket ) import Graphics.UI.Port.Types *************** *** 382,384 **** -- | Translate (or move) the canvas in a horizontal and vertical direction. ! foreign import ccall "osTranslateCanvas" translateCanvas :: Double -> Double -> CanvasHandle -> IO () \ No newline at end of file --- 382,384 ---- -- | Translate (or move) the canvas in a horizontal and vertical direction. ! foreign import ccall "osTranslateCanvas" translateCanvas :: Double -> Double -> CanvasHandle -> IO () Index: Font.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Font.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Font.hs 30 Jan 2003 21:56:14 -0000 1.4 --- Font.hs 8 Jun 2003 19:42:14 -0000 1.5 *************** *** 1,223 **** ! {-# OPTIONS -fglasgow-exts -#include Font.h #-} ! ----------------------------------------------------------------------------------------- ! {-| Module : Font ! Copyright : (c) Krasimir Angelov & Daan Leijen 2003 ! License : BSD-style ! ! Maintainer : ka2...@ya... da...@cs... ! Stability : provisional ! Portability : portable ! ! Fonts. ! -} ! ----------------------------------------------------------------------------------------- ! module Graphics.UI.Port.Font ! ( ! -- * Fonts ! createFont ! , defaultFont ! , dialogFont ! ! -- * Metrics (on a certain canvas). ! , getFontMetrics ! , getFontCharWidth ! , getFontStringWidth ! ! -- * Enumerate fonts ! , getFontNames, getFontVariants ! ! -- * Standard font definitions. ! , defaultFontDef ! , dialogFontDef ! , serifFontDef ! , sansSerifFontDef ! , nonProportionalFontDef ! , smallFontDef ! , symbolFontDef ! ) where ! ! import Graphics.UI.Port.Types ! ! import Foreign.C ! import Foreign.Ptr ! import Foreign.Marshal.Alloc ! import Foreign.Storable ! import Foreign.ForeignPtr ! ! import Data.FiniteMap ! import Data.List( sort, nub ) ! import Control.Monad ( when ) ! import System.IO.Unsafe ( unsafePerformIO ) ! import System.IO.Error ( mkIOError, doesNotExistErrorType ) ! import System.IO( bracket ) ! ! ! {----------------------------------------------------------------------------------------- ! Create ! -----------------------------------------------------------------------------------------} ! -- | Create a new font from a font definition. ! createFont :: FontDef -> IO Font ! createFont fontDef ! = withCFontDef fontDef $ \cname csize cweight cstyle cunderline cstrikeout -> ! do handle <- osCreateFont cname csize cweight cstyle cunderline cstrikeout ! when (nullPtr == handle) (ioError (mkIOError doesNotExistErrorType "createFont" Nothing (Just (show fontDef)))) ! fromCFont fontDef handle ! foreign import ccall osCreateFont :: CString -> CInt -> CInt -> CInt -> CBool -> CBool -> IO FontHandle ! ! ! ! {----------------------------------------------------------------------------------------- ! Font properties ! -----------------------------------------------------------------------------------------} ! ! insertUniq :: (Ord a) => a -> [a] -> [a] ! insertUniq a list@(b:x) ! | a<b = a:list ! | a>b = b:(insertUniq a x) ! | otherwise = list ! insertUniq a _ = [a] ! ! sortAndRemoveDuplicates :: (Ord a) => [a] -> [a] ! sortAndRemoveDuplicates (e:es) = insertUniq e (sortAndRemoveDuplicates es) ! sortAndRemoveDuplicates _ = [] ! ! -- | Enumerate all the available font names. ! getFontNames :: IO [FontName] ! getFontNames ! = do names <- resultCStrings (osGetAvailableFontNames) ! return (sortAndRemoveDuplicates names) ! foreign import ccall osGetAvailableFontNames :: IO CString; ! ! -- | The expression (@getFontVariants fontname min max@) returns all avaiable font definitions ! -- where the font name is @fontname@ and the font size is between @min@ and @max@ (inclusive). ! -- The keys in the returned map are all posible combinations between weight and style, ! -- and the value coresponding to them in the map is a list of sizes for which this combination is ! -- available. ! getFontVariants :: FontName -> FontSize -> FontSize -> IO (FiniteMap (FontWeight, FontStyle) [FontSize]) ! getFontVariants fontname low high ! = withCString fontname $ \cname -> ! bracket (osGetAvailableFontVariants cname (toCInt low') (toCInt high')) free decodeVariants ! where ! low' = max low 2 ! high' = max high 2 ! allFontSizes = [low'..high'] ! ! decodeVariants :: Ptr CInt -> IO (FiniteMap (FontWeight, FontStyle) [FontSize]) ! decodeVariants pints ! | pints == nullPtr = ioError (mkIOError doesNotExistErrorType "getFontVariants" Nothing (Just ("\"" ++ fontname ++ "\" fonts family"))) ! decodeVariants pints = do ! cweight <- peekElemOff pints 0 ! if cweight == 0 ! then return emptyFM ! else do ! cstyle <- peekElemOff pints 1 ! csize <- peekElemOff pints 2 ! variants <- decodeVariants (pints `plusPtr` (sizeOf cweight * 3)) ! let sizes = if csize == 0 then allFontSizes else [fromCInt csize] ! return (addToFM_C (foldr insertUniq) variants (fromCWeight cweight,fromCStyle cstyle) sizes) ! foreign import ccall osGetAvailableFontVariants :: CString -> CInt -> CInt -> IO (Ptr CInt); ! ! {----------------------------------------------------------------------------------------- ! Font metrics ! -----------------------------------------------------------------------------------------} ! -- | Get the font metrics of a specified font. ! getFontMetrics :: Font -> CanvasHandle -> IO FontMetrics ! getFontMetrics font canvas ! = withCFont font $ \cfont -> ! withCFontMetricsResult $ \pascent pdescent pmaxwidth pleading -> ! osGetFontMetrics cfont canvas pascent pdescent pmaxwidth pleading ! foreign import ccall osGetFontMetrics :: FontHandle -> CanvasHandle -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! -- | Get the pixel width of a character. ! getFontCharWidth :: Font -> Char -> CanvasHandle -> IO Int ! getFontCharWidth font c canvas ! = withCFont font $ \cfont -> ! do cw <- osGetFontCharWidth (toCChar c) cfont canvas ! return (fromCInt cw) ! foreign import ccall osGetFontCharWidth :: CChar -> FontHandle -> CanvasHandle -> IO CInt ! ! -- | Get the pixel width of a string. ! getFontStringWidth :: Font -> String -> CanvasHandle -> IO Int ! getFontStringWidth font str canvas ! = withCFont font $ \cfont -> ! withCString str $ \cstr -> ! do cw <- osGetFontStringWidth cstr cfont canvas ! return (fromCInt cw) ! foreign import ccall osGetFontStringWidth :: CString -> FontHandle -> CanvasHandle -> IO CInt ! ! ! {----------------------------------------------------------------------------------------- ! Default fonts ! -----------------------------------------------------------------------------------------} ! {-# NOINLINE defaultFont #-} ! -- | The default window font. ! defaultFont :: Font ! defaultFont ! = unsafePerformIO $ ! createFont defaultFontDef ! ! {-# NOINLINE dialogFont #-} ! -- | The default dialog font. ! dialogFont :: Font ! dialogFont ! = unsafePerformIO $ ! createFont dialogFontDef ! ! {-# NOINLINE defaultFontDef #-} ! defaultFontDef :: FontDef ! defaultFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osDefaultFontDef pname psize pweight pstyle ! foreign import ccall osDefaultFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE dialogFontDef #-} ! dialogFontDef :: FontDef ! dialogFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osDialogFontDef pname psize pweight pstyle ! foreign import ccall osDialogFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE serifFontDef #-} ! serifFontDef :: FontDef ! serifFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSerifFontDef pname psize pweight pstyle ! foreign import ccall osSerifFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE sansSerifFontDef #-} ! sansSerifFontDef :: FontDef ! sansSerifFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSansSerifFontDef pname psize pweight pstyle ! foreign import ccall osSansSerifFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE smallFontDef #-} ! smallFontDef :: FontDef ! smallFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSmallFontDef pname psize pweight pstyle ! foreign import ccall osSmallFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE nonProportionalFontDef #-} ! nonProportionalFontDef :: FontDef ! nonProportionalFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osNonProportionalFontDef pname psize pweight pstyle ! foreign import ccall osNonProportionalFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE symbolFontDef #-} ! symbolFontDef :: FontDef ! symbolFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSymbolFontDef pname psize pweight pstyle ! foreign import ccall osSymbolFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! ! --- 1,223 ---- ! {-# OPTIONS -fglasgow-exts -#include Font.h #-} ! ----------------------------------------------------------------------------------------- ! {-| Module : Font ! Copyright : (c) Krasimir Angelov & Daan Leijen 2003 ! License : BSD-style ! ! Maintainer : ka2...@ya... da...@cs... ! Stability : provisional ! Portability : portable ! ! Fonts. ! -} ! ----------------------------------------------------------------------------------------- ! module Graphics.UI.Port.Font ! ( ! -- * Fonts ! createFont ! , defaultFont ! , dialogFont ! ! -- * Metrics (on a certain canvas). ! , getFontMetrics ! , getFontCharWidth ! , getFontStringWidth ! ! -- * Enumerate fonts ! , getFontNames, getFontVariants ! ! -- * Standard font definitions. ! , defaultFontDef ! , dialogFontDef ! , serifFontDef ! , sansSerifFontDef ! , nonProportionalFontDef ! , smallFontDef ! , symbolFontDef ! ) where ! ! import Graphics.UI.Port.Types ! ! import Foreign.C ! import Foreign.Ptr ! import Foreign.Marshal.Alloc ! import Foreign.Storable ! import Foreign.ForeignPtr ! ! import Data.FiniteMap ! import Data.List( sort, nub ) ! import Control.Monad ( when ) ! import Control.Exception ( bracket ) ! import System.IO.Unsafe ( unsafePerformIO ) ! import System.IO.Error ( mkIOError, doesNotExistErrorType ) ! ! ! {----------------------------------------------------------------------------------------- ! Create ! -----------------------------------------------------------------------------------------} ! -- | Create a new font from a font definition. ! createFont :: FontDef -> IO Font ! createFont fontDef ! = withCFontDef fontDef $ \cname csize cweight cstyle cunderline cstrikeout -> ! do handle <- osCreateFont cname csize cweight cstyle cunderline cstrikeout ! when (nullPtr == handle) (ioError (mkIOError doesNotExistErrorType "createFont" Nothing (Just (show fontDef)))) ! fromCFont fontDef handle ! foreign import ccall osCreateFont :: CString -> CInt -> CInt -> CInt -> CBool -> CBool -> IO FontHandle ! ! ! ! {----------------------------------------------------------------------------------------- ! Font properties ! -----------------------------------------------------------------------------------------} ! ! insertUniq :: (Ord a) => a -> [a] -> [a] ! insertUniq a list@(b:x) ! | a<b = a:list ! | a>b = b:(insertUniq a x) ! | otherwise = list ! insertUniq a _ = [a] ! ! sortAndRemoveDuplicates :: (Ord a) => [a] -> [a] ! sortAndRemoveDuplicates (e:es) = insertUniq e (sortAndRemoveDuplicates es) ! sortAndRemoveDuplicates _ = [] ! ! -- | Enumerate all the available font names. ! getFontNames :: IO [FontName] ! getFontNames ! = do names <- resultCStrings (osGetAvailableFontNames) ! return (sortAndRemoveDuplicates names) ! foreign import ccall osGetAvailableFontNames :: IO CString; ! ! -- | The expression (@getFontVariants fontname min max@) returns all avaiable font definitions ! -- where the font name is @fontname@ and the font size is between @min@ and @max@ (inclusive). ! -- The keys in the returned map are all posible combinations between weight and style, ! -- and the value coresponding to them in the map is a list of sizes for which this combination is ! -- available. ! getFontVariants :: FontName -> FontSize -> FontSize -> IO (FiniteMap (FontWeight, FontStyle) [FontSize]) ! getFontVariants fontname low high ! = withCString fontname $ \cname -> ! bracket (osGetAvailableFontVariants cname (toCInt low') (toCInt high')) free decodeVariants ! where ! low' = max low 2 ! high' = max high 2 ! allFontSizes = [low'..high'] ! ! decodeVariants :: Ptr CInt -> IO (FiniteMap (FontWeight, FontStyle) [FontSize]) ! decodeVariants pints ! | pints == nullPtr = ioError (mkIOError doesNotExistErrorType "getFontVariants" Nothing (Just ("\"" ++ fontname ++ "\" fonts family"))) ! decodeVariants pints = do ! cweight <- peekElemOff pints 0 ! if cweight == 0 ! then return emptyFM ! else do ! cstyle <- peekElemOff pints 1 ! csize <- peekElemOff pints 2 ! variants <- decodeVariants (pints `plusPtr` (sizeOf cweight * 3)) ! let sizes = if csize == 0 then allFontSizes else [fromCInt csize] ! return (addToFM_C (foldr insertUniq) variants (fromCWeight cweight,fromCStyle cstyle) sizes) ! foreign import ccall osGetAvailableFontVariants :: CString -> CInt -> CInt -> IO (Ptr CInt); ! ! {----------------------------------------------------------------------------------------- ! Font metrics ! -----------------------------------------------------------------------------------------} ! -- | Get the font metrics of a specified font. ! getFontMetrics :: Font -> CanvasHandle -> IO FontMetrics ! getFontMetrics font canvas ! = withCFont font $ \cfont -> ! withCFontMetricsResult $ \pascent pdescent pmaxwidth pleading -> ! osGetFontMetrics cfont canvas pascent pdescent pmaxwidth pleading ! foreign import ccall osGetFontMetrics :: FontHandle -> CanvasHandle -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! -- | Get the pixel width of a character. ! getFontCharWidth :: Font -> Char -> CanvasHandle -> IO Int ! getFontCharWidth font c canvas ! = withCFont font $ \cfont -> ! do cw <- osGetFontCharWidth (toCChar c) cfont canvas ! return (fromCInt cw) ! foreign import ccall osGetFontCharWidth :: CChar -> FontHandle -> CanvasHandle -> IO CInt ! ! -- | Get the pixel width of a string. ! getFontStringWidth :: Font -> String -> CanvasHandle -> IO Int ! getFontStringWidth font str canvas ! = withCFont font $ \cfont -> ! withCString str $ \cstr -> ! do cw <- osGetFontStringWidth cstr cfont canvas ! return (fromCInt cw) ! foreign import ccall osGetFontStringWidth :: CString -> FontHandle -> CanvasHandle -> IO CInt ! ! ! {----------------------------------------------------------------------------------------- ! Default fonts ! -----------------------------------------------------------------------------------------} ! {-# NOINLINE defaultFont #-} ! -- | The default window font. ! defaultFont :: Font ! defaultFont ! = unsafePerformIO $ ! createFont defaultFontDef ! ! {-# NOINLINE dialogFont #-} ! -- | The default dialog font. ! dialogFont :: Font ! dialogFont ! = unsafePerformIO $ ! createFont dialogFontDef ! ! {-# NOINLINE defaultFontDef #-} ! defaultFontDef :: FontDef ! defaultFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osDefaultFontDef pname psize pweight pstyle ! foreign import ccall osDefaultFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE dialogFontDef #-} ! dialogFontDef :: FontDef ! dialogFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osDialogFontDef pname psize pweight pstyle ! foreign import ccall osDialogFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE serifFontDef #-} ! serifFontDef :: FontDef ! serifFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSerifFontDef pname psize pweight pstyle ! foreign import ccall osSerifFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE sansSerifFontDef #-} ! sansSerifFontDef :: FontDef ! sansSerifFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSansSerifFontDef pname psize pweight pstyle ! foreign import ccall osSansSerifFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE smallFontDef #-} ! smallFontDef :: FontDef ! smallFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSmallFontDef pname psize pweight pstyle ! foreign import ccall osSmallFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE nonProportionalFontDef #-} ! nonProportionalFontDef :: FontDef ! nonProportionalFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osNonProportionalFontDef pname psize pweight pstyle ! foreign import ccall osNonProportionalFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! {-# NOINLINE symbolFontDef #-} ! symbolFontDef :: FontDef ! symbolFontDef ! = unsafePerformIO $ ! withCFontDefResult $ \pname psize pweight pstyle punderline pstrikeout -> ! osSymbolFontDef pname psize pweight pstyle ! foreign import ccall osSymbolFontDef :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () ! ! ! Index: Handlers.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v retrieving revision 1.22 retrieving revision 1.23 diff -C2 -d -r1.22 -r1.23 *** Handlers.hs 27 Apr 2003 18:19:13 -0000 1.22 --- Handlers.hs 8 Jun 2003 19:42:14 -0000 1.23 *************** *** 37,41 **** ,setTimerHandler, setTimerDefHandler, getTimerHandler ,setTimerDestroyHandler, setTimerDestroyDefHandler, getTimerDestroyHandler - ,getAllTimerHandles -- * Windows --- 37,40 ---- Index: Types.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 *** Types.hs 1 Jun 2003 13:00:10 -0000 1.19 --- Types.hs 8 Jun 2003 19:42:15 -0000 1.20 *************** *** 1,3 **** ! {-# OPTIONS -fglasgow-exts -#include Font.h -#include Bitmap.h #-} -- the previous line is just needed for "osDeleteFont" and "osDeleteBitmap" :-( -- #hide --- 1,3 ---- ! {-# OPTIONS -fglasgow-exts -#include Font.h -#include Bitmap.h #-} -- the previous line is just needed for "osDeleteFont" and "osDeleteBitmap" :-( -- #hide *************** *** 116,120 **** import Foreign.C import Foreign.Marshal.Alloc ! import System.IO( bracket ) import Data.Bits import Graphics.UI.Port.Colors --- 116,120 ---- import Foreign.C import Foreign.Marshal.Alloc ! import Control.Exception( bracket ) import Data.Bits import Graphics.UI.Port.Colors *************** *** 854,860 **** fromCBitmap :: BitmapHandle -> IO Bitmap fromCBitmap bh ! = do bm <- newForeignPtr bh (osDeleteBitmap bh) return (Bitmap bm) ! foreign import ccall osDeleteBitmap :: BitmapHandle -> IO () withCBitmap :: Bitmap -> (BitmapHandle -> IO a) -> IO a --- 854,860 ---- fromCBitmap :: BitmapHandle -> IO Bitmap fromCBitmap bh ! = do bm <- newForeignPtr bh osDeleteBitmap return (Bitmap bm) ! foreign import ccall "&osDeleteBitmap" osDeleteBitmap :: FinalizerPtr BH withCBitmap :: Bitmap -> (BitmapHandle -> IO a) -> IO a *************** *** 941,947 **** fromCFont :: FontDef -> FontHandle -> IO Font fromCFont fontdef handle ! = do fhandle <- newForeignPtr handle (osDeleteFont handle) return (Font fhandle fontdef) ! foreign import ccall osDeleteFont :: FontHandle -> IO () toCStyle :: FontStyle -> CInt --- 941,947 ---- fromCFont :: FontDef -> FontHandle -> IO Font fromCFont fontdef handle ! = do fhandle <- newForeignPtr handle osDeleteFont return (Font fhandle fontdef) ! foreign import ccall "&osDeleteFont" osDeleteFont :: FinalizerPtr FH toCStyle :: FontStyle -> CInt Index: Window.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Window.hs,v retrieving revision 1.11 retrieving revision 1.12 diff -C2 -d -r1.11 -r1.12 *** Window.hs 30 May 2003 21:46:47 -0000 1.11 --- Window.hs 8 Jun 2003 19:42:15 -0000 1.12 *************** *** 40,45 **** import Foreign.Ptr import Foreign.Marshal.Alloc - import System.IO( bracket ) import System.IO.Unsafe( unsafePerformIO ) import Control.Concurrent.MVar import Control.Monad(when) --- 40,45 ---- import Foreign.Ptr import Foreign.Marshal.Alloc import System.IO.Unsafe( unsafePerformIO ) + import Control.Exception( bracket ) import Control.Concurrent.MVar import Control.Monad(when) |
|
From: <kr_...@us...> - 2003-06-08 19:42:17
|
Update of /cvsroot/htoolkit/port
In directory sc8-pr-cvs1:/tmp/cvs-serv2042/port
Modified Files:
configure makefile
Log Message:
Make HToolkit compatible with GHC-6.0
Index: configure
===================================================================
RCS file: /cvsroot/htoolkit/port/configure,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** configure 28 Apr 2003 11:22:51 -0000 1.11
--- configure 8 Jun 2003 19:42:14 -0000 1.12
***************
*** 427,430 ****
--- 427,431 ----
echo "Package" > config/port.pkg
echo " { name=\"port\"" >> config/port.pkg
+ echo " , auto=True" >> config/port.pkg
echo " , import_dirs=[\"$curdir/imports\"]" >> config/port.pkg
echo " , library_dirs=[\"$curdir\" $extralibdirs]" >> config/port.pkg
Index: makefile
===================================================================
RCS file: /cvsroot/htoolkit/port/makefile,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** makefile 2 May 2003 06:35:30 -0000 1.20
--- makefile 8 Jun 2003 19:42:14 -0000 1.21
***************
*** 157,161 ****
$(HOBJS): $(HOUTDIR)/%.o: %.hs
! $(HC) -o $@ -ohi $(IMPORTDIR)/Graphics/UI/$(*D)/$(*F).hi -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) $($(*F)_OPTIONS) -i$(IMPORTDIR) $(INCDIRS)
@# move stub files
@-if test -f $(<D)/$(*F)_stub.h; then $(MV) $(<D)/$(*F)_stub.[ch] $(HOUTDIR)/$(*D); fi
--- 157,161 ----
$(HOBJS): $(HOUTDIR)/%.o: %.hs
! $(HC) -o $@ -package-name port -ohi $(IMPORTDIR)/Graphics/UI/$(*D)/$(*F).hi -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) $($(*F)_OPTIONS) -i$(IMPORTDIR) $(INCDIRS)
@# move stub files
@-if test -f $(<D)/$(*F)_stub.h; then $(MV) $(<D)/$(*F)_stub.[ch] $(HOUTDIR)/$(*D); fi
|
|
From: <kr_...@us...> - 2003-06-08 19:42:17
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv2042/gio/src/Graphics/UI/GIO
Modified Files:
Canvas.hs Layout.hs Types.hs Window.hs
Log Message:
Make HToolkit compatible with GHC-6.0
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Canvas.hs 1 Jun 2003 14:04:12 -0000 1.12
--- Canvas.hs 8 Jun 2003 19:42:13 -0000 1.13
***************
*** 29,33 ****
(
-- * Canvas
! Canvas, CanvasPen, Pen(..)
, setCanvasPen, getCanvasPen
--- 29,33 ----
(
-- * Canvas
! Canvas, CanvasPen
, setCanvasPen, getCanvasPen
Index: Layout.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Layout.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Layout.hs 30 Jan 2003 23:58:33 -0000 1.4
--- Layout.hs 8 Jun 2003 19:42:13 -0000 1.5
***************
*** 118,122 ****
) where
! import List( transpose, intersperse )
import qualified Graphics.UI.Port as Port
import Graphics.UI.GIO.Types
--- 118,122 ----
) where
! import Data.List( transpose, intersperse )
import qualified Graphics.UI.Port as Port
import Graphics.UI.GIO.Types
***************
*** 495,497 ****
loop n (stretch:xs) | stretch && n > 0 = (delta+1):loop (n-1) xs
| stretch = delta:loop 0 xs
! | otherwise = 0:loop (n-1) xs
\ No newline at end of file
--- 495,497 ----
loop n (stretch:xs) | stretch && n > 0 = (delta+1):loop (n-1) xs
| stretch = delta:loop 0 xs
! | otherwise = 0:loop (n-1) xs
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Types.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** Types.hs 1 Jun 2003 15:06:54 -0000 1.11
--- Types.hs 8 Jun 2003 19:42:13 -0000 1.12
***************
*** 11,28 ****
-}
-----------------------------------------------------------------------------------------
! module Graphics.UI.GIO.Types
! (
-- * Geometry
-- ** Size
! Size(..), sz, sw, sh
, sizeEncloses
-- ** Point
! , Point(..), pt, px, py
, pointFromVec
, pointMove
-- ** Vector
! , Vector(..), vc, vx, vy
, vecNegate, vecFromPoint
--- 11,28 ----
-}
-----------------------------------------------------------------------------------------
! module Graphics.UI.GIO.Types
! (
-- * Geometry
-- ** Size
! Size(..), sz
, sizeEncloses
-- ** Point
! , Point(..), pt
, pointFromVec
, pointMove
-- ** Vector
! , Vector(..), vc
, vecNegate, vecFromPoint
***************
*** 35,51 ****
, disjointRects
, rectsDiff
!
-- *** Construction
, rect
, rectAt
, rectOfSize
!
-- *** Access
- , left, right, top, bottom
, topLeft, topRight, bottomLeft, bottomRight
, rectSize, rectIsEmpty, pointInRect, pointToRect
, centralPoint, centralRect
!
!
-- * Events
--- 35,50 ----
, disjointRects
, rectsDiff
!
-- *** Construction
, rect
, rectAt
, rectOfSize
!
-- *** Access
, topLeft, topRight, bottomLeft, bottomRight
, rectSize, rectIsEmpty, pointInRect, pointToRect
, centralPoint, centralRect
!
!
-- * Events
***************
*** 151,153 ****
getColorRGB :: Color -> (Int,Int,Int)
getColorRGB c
! = (fromIntegral $ colorRed c, fromIntegral $ colorGreen c, fromIntegral $ colorBlue c)
\ No newline at end of file
--- 150,152 ----
getColorRGB :: Color -> (Int,Int,Int)
getColorRGB c
! = (fromIntegral $ colorRed c, fromIntegral $ colorGreen c, fromIntegral $ colorBlue c)
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** Window.hs 8 Jun 2003 11:19:13 -0000 1.18
--- Window.hs 8 Jun 2003 19:42:13 -0000 1.19
***************
*** 12,16 ****
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize, bufferMode
, dialog, runDialog
, drawInWindow
--- 12,16 ----
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize
, dialog, runDialog
, drawInWindow
|
|
From: <kr_...@us...> - 2003-06-08 11:27:45
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv29834/src/Graphics/UI/GIO
Modified Files:
Menu.hs
Log Message:
Implement class Able for Menu
Index: Menu.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Menu.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Menu.hs 23 Apr 2003 21:48:47 -0000 1.6
--- Menu.hs 8 Jun 2003 11:27:42 -0000 1.7
***************
*** 58,62 ****
menu :: [Prop Menu] -> Menu -> IO Menu
menu = menuAt Nothing
!
instance Titled Menu where
title = newAttr (Lib.getMenuLabel . hmenu) (Lib.setMenuLabel . hmenu)
--- 58,65 ----
menu :: [Prop Menu] -> Menu -> IO Menu
menu = menuAt Nothing
!
! instance Able Menu where
! enabled = newAttr (Lib.getMenuItemEnabled . hmenu) (Lib.setMenuItemEnabled . hmenu)
!
instance Titled Menu where
title = newAttr (Lib.getMenuLabel . hmenu) (Lib.setMenuLabel . hmenu)
|
|
From: <kr_...@us...> - 2003-06-08 11:19:16
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv27147/src/Graphics/UI/GIO
Modified Files:
Window.hs
Log Message:
bugfix
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -d -r1.17 -r1.18
*** Window.hs 30 May 2003 21:55:07 -0000 1.17
--- Window.hs 8 Jun 2003 11:19:13 -0000 1.18
***************
*** 95,100 ****
avail <- get w view
isresize <- get w resizeable
! when ((not isresize && avail /= needed) || (isresize && not (sizeEncloses avail needed)))
! (do set w [view =: needed]))
layoutInWindow (hwindow w) lay
return ()
--- 95,99 ----
avail <- get w view
isresize <- get w resizeable
! when (not (sizeEncloses avail needed)) (set w [view =: needed]))
layoutInWindow (hwindow w) lay
return ()
|
|
From: <kr_...@us...> - 2003-06-08 11:18:03
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv26186/src/Graphics/UI/GIO
Modified Files:
Attributes.hs
Log Message:
Export drawMode and bkDrawMode attributes
Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Attributes.hs 30 May 2003 21:55:06 -0000 1.12
--- Attributes.hs 8 Jun 2003 11:18:00 -0000 1.13
***************
*** 55,58 ****
--- 55,59 ----
, color, bgcolor, hatch
, thickness, capstyle, linestyle, joinstyle
+ , drawMode, bkDrawMode
-- ** Titled
|
|
From: <kr_...@us...> - 2003-06-08 11:11:06
|
Update of /cvsroot/htoolkit/gio/src/examples/worm In directory sc8-pr-cvs1:/tmp/cvs-serv24454 Modified Files: Main.hs Log Message: formatting Index: Main.hs =================================================================== RCS file: /cvsroot/htoolkit/gio/src/examples/worm/Main.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Main.hs 8 Jun 2003 10:25:07 -0000 1.2 --- Main.hs 8 Jun 2003 11:11:03 -0000 1.3 *************** *** 29,33 **** mfile <- menu [title =: "File"] mainMenu mnew <- menuitem [title =: "New", accel =: KeyChar '\^N'] mfile ! mplay <- menuitem [title =: "Play", accel =: KeyChar '\^P'] mfile menuline mfile mexit <- menuitem [title =: "Exit", on command =: halt] mfile --- 29,33 ---- mfile <- menu [title =: "File"] mainMenu mnew <- menuitem [title =: "New", accel =: KeyChar '\^N'] mfile ! mplay <- menuitem [title =: "Play", accel =: KeyChar '\^P'] mfile menuline mfile mexit <- menuitem [title =: "Exit", on command =: halt] mfile |
|
From: <kr_...@us...> - 2003-06-08 11:10:06
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv24251/src/cbits/Win32
Modified Files:
Menu.c
Log Message:
bugfix
Index: Menu.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Menu.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** Menu.c 8 Jun 2003 08:17:52 -0000 1.8
--- Menu.c 8 Jun 2003 11:10:02 -0000 1.9
***************
*** 100,109 ****
SetWindowPos(pFrameData->hClientWnd,NULL,rc.left,rc.top,rc.right,rc.bottom,SWP_NOZORDER);
DrawMenuBar(ghWndFrame);
-
- if (pFrameData->DocumentInterface == 1)
- {
- handleWindowResize(pFrameData->hClientWnd,rc.right-rc.left,rc.bottom-rc.top);
- handleWindowReLayout(pFrameData->hClientWnd);
- }
}
}
--- 100,103 ----
|
|
From: <kr_...@us...> - 2003-06-08 10:25:44
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv12434/src/cbits/Win32
Modified Files:
Window.c
Log Message:
bugfix
Index: Window.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Window.c,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -d -r1.30 -r1.31
*** Window.c 8 Jun 2003 08:17:52 -0000 1.30
--- Window.c 8 Jun 2003 10:25:41 -0000 1.31
***************
*** 1411,1415 ****
{
RECT rect;
! LONG style = GetWindowLong(hwnd, GWL_STYLE );
if (resizeable) style |= WS_THICKFRAME;
else style &= ~WS_THICKFRAME;
--- 1411,1421 ----
{
RECT rect;
! LONG style;
! FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
!
! if (pFrameData->DocumentInterface == 1)
! hwnd = ghWndFrame;
!
! style = GetWindowLong(hwnd, GWL_STYLE );
if (resizeable) style |= WS_THICKFRAME;
else style &= ~WS_THICKFRAME;
|
|
From: <kr_...@us...> - 2003-06-08 10:25:10
|
Update of /cvsroot/htoolkit/gio/src/examples/worm In directory sc8-pr-cvs1:/tmp/cvs-serv12405 Modified Files: Main.hs Log Message: final release Index: Main.hs =================================================================== RCS file: /cvsroot/htoolkit/gio/src/examples/worm/Main.hs,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Main.hs 7 Jun 2003 18:30:05 -0000 1.1 --- Main.hs 8 Jun 2003 10:25:07 -0000 1.2 *************** *** 12,16 **** -- GUI constants. - helpFile = "WormHelp" hiScoresFile = "wormhi" nrOfHiScores = 8 --- 12,15 ---- *************** *** 26,38 **** startWorm best = do ref <- newIORef (initState best) - - -- Main window - w <- window [ bgcolor =: wormBackGroundColour - , bkDrawMode =: True - , view =: Size 488 303 - , on paint =: onPaint ref - , on dismiss =: halt - , resizeable =: False - ] -- File menu --- 25,28 ---- *************** *** 56,59 **** --- 46,58 ---- menuitem [title =: "About Worm...", on command =: onAbout] mhelp + -- Main window + w <- window [ bgcolor =: wormBackGroundColour + , bkDrawMode =: True + , view =: Size 488 303 + , on paint =: onPaint ref + , on dismiss =: halt + , resizeable =: False + ] + -- Timer tm <- timer [enabled =: False] *************** *** 154,159 **** let onOK refName dlg e = do get e title >>= writeIORef refName ! dismissWidget dlg ! return () btnOK <- button [title =: "OK", on command =: onOK refName dlg e] dlg set dlg [layout =: padding 5 (lbl1 ^^^ padding 15 (lbl2 ^^^ hfill e) ^^^ hcenter btnOK)] --- 153,157 ---- let onOK refName dlg e = do get e title >>= writeIORef refName ! destroyWidget dlg btnOK <- button [title =: "OK", on command =: onOK refName dlg e] dlg set dlg [layout =: padding 5 (lbl1 ^^^ padding 15 (lbl2 ^^^ hfill e) ^^^ hcenter btnOK)] |
221 messages has been excluded from this view by a project administrator.
