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-06-08 08:17:58
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv7969/src/cbits/Win32
Modified Files:
Menu.c Window.c
Log Message:
bugfixes
Index: Menu.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Menu.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** Menu.c 26 Apr 2003 20:01:33 -0000 1.7
--- Menu.c 8 Jun 2003 08:17:52 -0000 1.8
***************
*** 96,104 ****
RECT rc;
FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
!
GetClientRect(ghWndFrame, &rc);
SetWindowPos(pFrameData->hClientWnd,NULL,rc.left,rc.top,rc.right,rc.bottom,SWP_NOZORDER);
DrawMenuBar(ghWndFrame);
!
if (pFrameData->DocumentInterface == 1)
{
--- 96,104 ----
RECT rc;
FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
!
GetClientRect(ghWndFrame, &rc);
SetWindowPos(pFrameData->hClientWnd,NULL,rc.left,rc.top,rc.right,rc.bottom,SWP_NOZORDER);
DrawMenuBar(ghWndFrame);
!
if (pFrameData->DocumentInterface == 1)
{
***************
*** 239,242 ****
--- 239,243 ----
deleteMenuHandle(pFrameData->pMenuHandlesMap, handle);
+ updateMenuBar(handle->parent);
}
***************
*** 256,264 ****
FrameData *pFrameData;
! CHECK_MENU_TYPE_V(handle, MENU_RADIO_ITEM | MENU_CHECK_ITEM | MENU_ITEM);
pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
EnableMenuItem(getParentHMENU(handle), getMenuPos(pFrameData->pMenuHandlesMap, handle), (bState ? MF_ENABLED : MF_GRAYED) | MF_BYPOSITION);
};
--- 257,266 ----
FrameData *pFrameData;
! CHECK_MENU_TYPE_V(handle, MENU_RADIO_ITEM | MENU_CHECK_ITEM | MENU_ITEM | MENU_POPUP);
pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
EnableMenuItem(getParentHMENU(handle), getMenuPos(pFrameData->pMenuHandlesMap, handle), (bState ? MF_ENABLED : MF_GRAYED) | MF_BYPOSITION);
+ updateMenuBar(handle->parent);
};
***************
*** 268,272 ****
FrameData *pFrameData;
! CHECK_MENU_TYPE(handle, MENU_RADIO_ITEM | MENU_CHECK_ITEM | MENU_ITEM, FALSE);
pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
--- 270,274 ----
FrameData *pFrameData;
! CHECK_MENU_TYPE(handle, MENU_RADIO_ITEM | MENU_CHECK_ITEM | MENU_ITEM | MENU_POPUP, FALSE);
pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
***************
*** 287,290 ****
--- 289,293 ----
CheckMenuItem(getParentHMENU(handle), getMenuPos(pFrameData->pMenuHandlesMap, handle), (bState ? MF_CHECKED : MF_UNCHECKED) | MF_BYPOSITION);
+ updateMenuBar(handle->parent);
handleMenuCommand(handle);
***************
*** 323,326 ****
--- 326,330 ----
CheckMenuRadioItem(hParent, pos, pos+getChildrenCount(pFrameData->pMenuHandlesMap, handle)-1, pos+index, MF_BYPOSITION);
+ updateMenuBar(handle->parent);
handleMenuCommand(child);
Index: Window.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Window.c,v
retrieving revision 1.29
retrieving revision 1.30
diff -C2 -d -r1.29 -r1.30
*** Window.c 1 May 2003 20:35:28 -0000 1.29
--- Window.c 8 Jun 2003 08:17:52 -0000 1.30
***************
*** 166,169 ****
--- 166,171 ----
pData->hTooltip = NULL;
SetWindowLong(hWnd,GWL_USERDATA,(LONG) pData);
+
+ SetFocus(hWnd);
}
break;
***************
*** 789,793 ****
switch (uMsg)
{
! case WM_CLOSE:
{
HWND hOwner = GetWindow(hWnd, GW_OWNER);
--- 791,795 ----
switch (uMsg)
{
! case WM_DESTROY:
{
HWND hOwner = GetWindow(hWnd, GW_OWNER);
|
|
From: <kr_...@us...> - 2003-06-07 18:30:08
|
Update of /cvsroot/htoolkit/gio/src/examples/worm
In directory sc8-pr-cvs1:/tmp/cvs-serv487/worm
Added Files:
HighScore.hs Main.hs WormShow.hs WormState.hs logo.bmp wormhi
Log Message:
Add Worm example`
--- NEW FILE: HighScore.hs ---
module HighScore
( HiScores, HiScore(..)
, readHiScores
, writeHiScores
, itsAHighScore
, addScore
, showHiScores
) where
import Graphics.UI.GIO
type HiScores = [HiScore]
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
--- NEW FILE: Main.hs ---
module Main where
import Graphics.UI.GIO
import WormShow
import WormState
--import Help
import HighScore
import System.Random
import Data.IORef
import Control.Monad(when)
-- GUI constants.
helpFile = "WormHelp"
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)
-- Main window
w <- window [ bgcolor =: wormBackGroundColour
, bkDrawMode =: True
, view =: Size 488 303
, on paint =: onPaint ref
, on dismiss =: halt
, resizeable =: False
]
-- 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
-- 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
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)]
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
-}
--- NEW FILE: WormShow.hs ---
module WormShow
( drawGame
, drawStep
, drawAnimation
, eraseSegment
, wormBackGroundColour
, nrAnimationSteps
) where
import Graphics.UI.GIO
import WormState
import Control.Monad(when)
-- 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 ()
eraseSegment segment = drawSegment wormBackGroundColour segment
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]
-- Close the Playfield between two levels.
drawAnimation :: Int -> Int -> Canvas -> IO ()
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
--- NEW FILE: WormState.hs ---
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
import HighScore
import Random
-- 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)
--- NEW FILE: logo.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: wormhi ---
HiScore {name = "Krasimir Angelov", score = 200000}
HiScore {name = "Ivanka Ivanova", score = 190000}
HiScore {name = "Krasimir Angelov", score = 57}
|
|
From: <kr_...@us...> - 2003-06-07 18:27:47
|
Update of /cvsroot/htoolkit/gio/src/examples/worm In directory sc8-pr-cvs1:/tmp/cvs-serv32376/worm Log Message: Directory /cvsroot/htoolkit/gio/src/examples/worm added to the repository |
Update of /cvsroot/htoolkit/gio/src/examples/picture
In directory sc8-pr-cvs1:/tmp/cvs-serv6364
Added Files:
Main.hs open.bmp rleft.bmp rright.bmp test.pic xminus.bmp
xplus.bmp yminus.bmp yplus.bmp
Log Message:
Add new sample
--- NEW FILE: Main.hs ---
module Main where
import Graphics.UI.GIO
import System
import Control.Monad.Trans
import Data.IORef
data Picture
= NullPic
| Pixel
| Text String
| PolyLine [Point]
| Rectangle Size
| Arc Size Double Double
| Curve Point Point Point
-- | Raster Bitmap
| Pen PenModifier Picture
| Move Offset Picture
| Transform Transformation Picture
| Tag Tag Picture
| Overlay Picture Picture
| ConstrainOverlay RelSize RelSize Picture Picture
| Clip Picture Picture
deriving (Read,Show)
data RelSize
= None
| Fixed Bool Int
| Prop Bool Double
deriving (Read, Show)
type Tag = Int
data Offset
= OffDir CompassDirection
| OffPropX Double
| OffPropY Double
deriving (Read, Show)
-- A.1 Graphical attributes
-- The Pen constructor associates a set of graphical (attribute,value) pairs
-- with a picture. The attributes currently supported are (the definition
-- of the types used by some of the attributes have been elided for lack of
-- space):
type PenModifier = [PenAttr]
data PenAttr
= Foreground Color
| LineStyle LineStyle -- dashed lines or not?
| JoinStyle JoinStyle -- for polyline joints
| CapStyle CapStyle -- end point caps.
| Fill Bool -- fill picture or not?
| Invisible Bool -- should the picture be drawn?
-- | Font Font -- what font to use.
-- | Function PenFunction -- blit op to eventually apply
deriving (Read, Show)
data Transformation
= Identity
| Scale Double Double
| Rotate Double
| Xlt Double Double
| Combine Transformation Transformation
deriving (Read, Show)
data CompassDirection
= West
| NorthWest
| North
| NorthEast
| East
| EastSouth
| South
| SouthWest
| Centre
deriving (Read, Show)
-------------------------------------------------------------------------
main = start "Picture" "1.0" SDI [] initPic
initPic = do
bmpOpen <- readBitmap "open.bmp" []
mfile <- menu [title =: "&File"] mainMenu
mopen <- menuitem [title =: "&Open", accel =: KeyChar '\^O', menuicon =: Just bmpOpen] mfile
mclose <- menuitem [title =: "&Close", enabled=:False] mfile
menuline mfile
menuitem [title =: "&Exit", on command =: halt] mfile
set mopen [on command =: onFileOpen mclose]
return ()
where
onFileOpen mclose = do
mb_fname <- runInputFileDialog "Open picture" [("Picture (*.pic)",["*.pic"])] Nothing
case mb_fname of
Nothing -> return ()
Just fname -> do
bmpRLeft <- readBitmap "rleft.bmp" []
bmpRRight <- readBitmap "rright.bmp" []
bmpXPlus <- readBitmap "xplus.bmp" []
bmpXMinus <- readBitmap "xminus.bmp" []
bmpYPlus <- readBitmap "yplus.bmp" []
bmpYMinus <- readBitmap "yminus.bmp" []
(pic :: Picture) <- fmap read (readFile fname)
ref <- newIORef (0,1,1)
w <- window [title =: fname, view =: sz 400 400]
mpic <- menu [title =: "&Picture"] mainMenu
menuitem [title =: "Rotate Left", accel =: KeyChar '\^L', menuicon =: Just bmpRLeft, on command =: onRotatePicture w (-pi/4) ref] mpic
menuitem [title =: "Rotate Right", accel =: KeyChar '\^R', menuicon =: Just bmpRRight, on command =: onRotatePicture w ( pi/4) ref] mpic
menuline mpic
menuitem [title =: "ScaleX +", accel =: KeyChar 'X', menuicon =: Just bmpXPlus, on command =: onScalePicture w (2 ,1) pic ref] mpic
menuitem [title =: "ScaleX -", accel =: KeyChar '\^X', menuicon =: Just bmpXMinus, on command =: onScalePicture w (0.5,1) pic ref] mpic
menuline mpic
menuitem [title =: "ScaleY +", accel =: KeyChar 'Y', menuicon =: Just bmpYPlus, on command =: onScalePicture w (1,2 ) pic ref] mpic
menuitem [title =: "ScaleY -", accel =: KeyChar '\^Y', menuicon =: Just bmpYMinus, on command =: onScalePicture w (1,0.5) pic ref] mpic
set mclose [enabled =: True, on command =: destroyWidget w]
set w [ on destroy =: onDestroyPicWindow mpic mclose
, on resize =: \s -> repaint w
, on paint =: onPaint w pic ref
]
where
onDestroyPicWindow mpic mclose = do
set mclose [enabled =: False, off command]
destroyWidget mpic
onRotatePicture w delta ref = do
modifyIORef ref (\(angle,scalex,scaley) -> (angle+delta,scalex,scaley))
repaint w
onScalePicture w (sx,sy) pic ref = do
modifyIORef ref (\(angle,scalex,scaley) -> (angle,scalex*sx,scaley*sy))
repaint w
onPaint w pic ref can _ _ = do
(angle,scalex,scaley) <- readIORef ref
Size x y <- get w view
translateCanvas (fromIntegral (x `quot` 2)) (fromIntegral (y `quot` 2)) can
rotateCanvas angle can
scaleCanvas scalex scaley can
renderPicture can pic
renderPicture :: Canvas -> Picture -> IO ()
renderPicture can NullPic = return ()
renderPicture can (Overlay pic1 pic2) = do
renderPicture can pic1
renderPicture can pic2
renderPicture can (Transform trans pic) = do
applyTransformation trans
renderPicture can pic
undoTransformation trans
where
applyTransformation :: Transformation -> IO ()
applyTransformation Identity = return ()
applyTransformation (Combine t1 t2) = applyTransformation t1 >> applyTransformation t2
applyTransformation (Rotate d) = rotateCanvas d can
applyTransformation (Scale dsx dsy) = scaleCanvas dsx dsy can
applyTransformation (Xlt dx dy) = translateCanvas dx dy can
undoTransformation :: Transformation -> IO ()
undoTransformation Identity = return ()
undoTransformation (Combine t1 t2) = undoTransformation t2 >> undoTransformation t1
undoTransformation (Rotate d) = rotateCanvas (-d) can
undoTransformation (Scale dsx dsy) = scaleCanvas (1/dsx) (1/dsy) can
undoTransformation (Xlt dx dy) = translateCanvas dx dy can
renderPicture can (Text txt) = drawString (pt 0 0) txt can
renderPicture can Pixel = drawPoint (pt 0 0) can
renderPicture can (PolyLine lines) = drawPolyline lines can
renderPicture can (Rectangle rsize)= drawRect (rectOfSize rsize) can
--- NEW FILE: open.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: rleft.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: rright.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: test.pic ---
Overlay
(Overlay
(Transform
(Xlt 50 0)
(Text "Hello")
)
(Transform
(Xlt 20 55)
(Text "Test")
)
)
(Transform
(Combine
(Rotate 89.54)
(Scale 0.5 0.5)
)
(Rectangle (Size{sw=100,sh=100}))
)
--- NEW FILE: xminus.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: xplus.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: yminus.bmp ---
(This appears to be a binary file; contents omitted.)
--- NEW FILE: yplus.bmp ---
(This appears to be a binary file; contents omitted.)
|
|
From: <kr_...@us...> - 2003-06-01 15:21:29
|
Update of /cvsroot/htoolkit/gio/src/examples/picture In directory sc8-pr-cvs1:/tmp/cvs-serv30265/picture Log Message: Directory /cvsroot/htoolkit/gio/src/examples/picture added to the repository |
|
From: <kr_...@us...> - 2003-06-01 15:06:57
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv24942/src/Graphics/UI/GIO
Modified Files:
Types.hs
Log Message:
Export extra Rect related functions
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Types.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Types.hs 30 May 2003 11:39:08 -0000 1.10
--- Types.hs 1 Jun 2003 15:06:54 -0000 1.11
***************
*** 32,35 ****
--- 32,38 ----
, rectMove
, rectUnion
+ , rectSect
+ , disjointRects
+ , rectsDiff
-- *** Construction
***************
*** 41,45 ****
, left, right, top, bottom
, topLeft, topRight, bottomLeft, bottomRight
! , rectSize
-- * Events
--- 44,50 ----
, left, right, top, bottom
, topLeft, topRight, bottomLeft, bottomRight
! , rectSize, rectIsEmpty, pointInRect, pointToRect
! , centralPoint, centralRect
!
-- * Events
|
|
From: <kr_...@us...> - 2003-06-01 14:04:15
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv5441/src/Graphics/UI/GIO
Modified Files:
Canvas.hs
Log Message:
Add drawPoint primitive
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** Canvas.hs 31 May 2003 19:08:37 -0000 1.11
--- Canvas.hs 1 Jun 2003 14:04:12 -0000 1.12
***************
*** 35,38 ****
--- 35,39 ----
-- * Drawing primitives
+ , drawPoint
, drawString
, drawLine
***************
*** 158,161 ****
--- 159,166 ----
-- Drawing primitives
--------------------------------------------------------------------
+
+ -- | Draws a point at the specified location.
+ drawPoint :: Point -> Canvas -> IO ()
+ drawPoint p can = Port.drawPoint p (hcanvas can)
-- | Draws the specified text string at the specified location.
|
|
From: <kr_...@us...> - 2003-06-01 13:20:14
|
Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv15950/src/Port
Modified Files:
Colors.hs Types.hs
Log Message:
Added Read instances for Color and some other primitive typs
Index: Colors.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Colors.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Colors.hs 15 Mar 2003 22:33:10 -0000 1.2
--- Colors.hs 1 Jun 2003 13:00:09 -0000 1.3
***************
*** 57,60 ****
--- 57,63 ----
import Data.Word
import Data.Bits
+ import GHC.Read
+ import Text.Read
+ import Text.ParserCombinators.ReadPrec
newtype Color = Color Word deriving Eq
***************
*** 206,209 ****
--- 209,374 ----
showChar ' ' . shows (colorGreen c) .
showChar ' ' . shows (colorBlue c))
+
+ instance Read Color where
+ readPrec =
+ do { Ident "aliceblue" <- lexP; return aliceblue } +++
+ do { Ident "antiquewhite" <- lexP; return antiquewhite } +++
+ do { Ident "aqua" <- lexP; return aqua } +++
+ do { Ident "aquamarine" <- lexP; return aquamarine } +++
+ do { Ident "azure" <- lexP; return azure } +++
+ do { Ident "beige" <- lexP; return beige } +++
+ do { Ident "bisque" <- lexP; return bisque } +++
+ do { Ident "black" <- lexP; return black } +++
+ do { Ident "blanchedalmond" <- lexP; return blanchedalmond } +++
+ do { Ident "blue" <- lexP; return blue } +++
+ do { Ident "blueviolet" <- lexP; return blueviolet } +++
+ do { Ident "brown" <- lexP; return brown } +++
+ do { Ident "burlywood" <- lexP; return burlywood } +++
+ do { Ident "cadetblue" <- lexP; return cadetblue } +++
+ do { Ident "chartreuse" <- lexP; return chartreuse } +++
+ do { Ident "chocolate" <- lexP; return chocolate } +++
+ do { Ident "coral" <- lexP; return coral } +++
+ do { Ident "cornflower" <- lexP; return cornflower } +++
+ do { Ident "cornsilk" <- lexP; return cornsilk } +++
+ do { Ident "crimson" <- lexP; return crimson } +++
+ do { Ident "cyan" <- lexP; return cyan } +++
+ do { Ident "darkblue" <- lexP; return darkblue } +++
+ do { Ident "darkcyan" <- lexP; return darkcyan } +++
+ do { Ident "darkgoldenrod" <- lexP; return darkgoldenrod } +++
+ do { Ident "darkgray" <- lexP; return darkgray } +++
+ do { Ident "darkgreen" <- lexP; return darkgreen } +++
+ do { Ident "darkkhaki" <- lexP; return darkkhaki } +++
+ do { Ident "darkmagenta" <- lexP; return darkmagenta } +++
+ do { Ident "darkolivegreen" <- lexP; return darkolivegreen } +++
+ do { Ident "darkorange" <- lexP; return darkorange } +++
+ do { Ident "darkorchid" <- lexP; return darkorchid } +++
+ do { Ident "darkred" <- lexP; return darkred } +++
+ do { Ident "darksalmon" <- lexP; return darksalmon } +++
+ do { Ident "darkseagreen" <- lexP; return darkseagreen } +++
+ do { Ident "darkslateblue" <- lexP; return darkslateblue } +++
+ do { Ident "darkslategray" <- lexP; return darkslategray } +++
+ do { Ident "darkturquoise" <- lexP; return darkturquoise } +++
+ do { Ident "darkviolet" <- lexP; return darkviolet } +++
+ do { Ident "deeppink" <- lexP; return deeppink } +++
+ do { Ident "deepskyblue" <- lexP; return deepskyblue } +++
+ do { Ident "dimgray" <- lexP; return dimgray } +++
+ do { Ident "dodgerblue" <- lexP; return dodgerblue } +++
+ do { Ident "firebrick" <- lexP; return firebrick } +++
+ do { Ident "floralwhite" <- lexP; return floralwhite } +++
+ do { Ident "forestgreen" <- lexP; return forestgreen } +++
+ do { Ident "fuchsia" <- lexP; return fuchsia } +++
+ do { Ident "gainsboro" <- lexP; return gainsboro } +++
+ do { Ident "ghostwhite" <- lexP; return ghostwhite } +++
+ do { Ident "gold" <- lexP; return gold } +++
+ do { Ident "goldenrod" <- lexP; return goldenrod } +++
+ do { Ident "gray" <- lexP; return gray } +++
+ do { Ident "green" <- lexP; return green } +++
+ do { Ident "greenyellow" <- lexP; return greenyellow } +++
+ do { Ident "honeydew" <- lexP; return honeydew } +++
+ do { Ident "hotpink" <- lexP; return hotpink } +++
+ do { Ident "indianred" <- lexP; return indianred } +++
+ do { Ident "indigo" <- lexP; return indigo } +++
+ do { Ident "ivory" <- lexP; return ivory } +++
+ do { Ident "khaki" <- lexP; return khaki } +++
+ do { Ident "lavender" <- lexP; return lavender } +++
+ do { Ident "lavenderblush" <- lexP; return lavenderblush } +++
+ do { Ident "lawngreen" <- lexP; return lawngreen } +++
+ do { Ident "lemonchiffon" <- lexP; return lemonchiffon } +++
+ do { Ident "lightblue" <- lexP; return lightblue } +++
+ do { Ident "lightcoral" <- lexP; return lightcoral } +++
+ do { Ident "lightcyan" <- lexP; return lightcyan } +++
+ do { Ident "lightgoldenrodyellow"<- lexP; return lightgoldenrodyellow} +++
+ do { Ident "lightgreen" <- lexP; return lightgreen } +++
+ do { Ident "lightgray" <- lexP; return lightgray } +++
+ do { Ident "lightpink" <- lexP; return lightpink } +++
+ do { Ident "lightsalmon" <- lexP; return lightsalmon } +++
+ do { Ident "lightseagreen" <- lexP; return lightseagreen } +++
+ do { Ident "lightskyblue" <- lexP; return lightskyblue } +++
+ do { Ident "lightslategray" <- lexP; return lightslategray } +++
+ do { Ident "lightsteelblue" <- lexP; return lightsteelblue } +++
+ do { Ident "lightyellow" <- lexP; return lightyellow } +++
+ do { Ident "lime" <- lexP; return lime } +++
+ do { Ident "limegreen" <- lexP; return limegreen } +++
+ do { Ident "linen" <- lexP; return linen } +++
+ do { Ident "magenta" <- lexP; return magenta } +++
+ do { Ident "maroon" <- lexP; return maroon } +++
+ do { Ident "mediumaquamarine" <- lexP; return mediumaquamarine } +++
+ do { Ident "mediumblue" <- lexP; return mediumblue } +++
+ do { Ident "mediumorchid" <- lexP; return mediumorchid } +++
+ do { Ident "mediumpurple" <- lexP; return mediumpurple } +++
+ do { Ident "mediumseagreen" <- lexP; return mediumseagreen } +++
+ do { Ident "mediumslateblue" <- lexP; return mediumslateblue } +++
+ do { Ident "mediumspringgreen" <- lexP; return mediumspringgreen } +++
+ do { Ident "mediumturquoise" <- lexP; return mediumturquoise } +++
+ do { Ident "mediumvioletred" <- lexP; return mediumvioletred } +++
+ do { Ident "midnightblue" <- lexP; return midnightblue } +++
+ do { Ident "mintcream" <- lexP; return mintcream } +++
+ do { Ident "mistyrose" <- lexP; return mistyrose } +++
+ do { Ident "moccasin" <- lexP; return moccasin } +++
+ do { Ident "navajowhite" <- lexP; return navajowhite } +++
+ do { Ident "navy" <- lexP; return navy } +++
+ do { Ident "oldlace" <- lexP; return oldlace } +++
+ do { Ident "olive" <- lexP; return olive } +++
+ do { Ident "olivedrab" <- lexP; return olivedrab } +++
+ do { Ident "orange" <- lexP; return orange } +++
+ do { Ident "orangered" <- lexP; return orangered } +++
+ do { Ident "orchid" <- lexP; return orchid } +++
+ do { Ident "palegoldenrod" <- lexP; return palegoldenrod } +++
+ do { Ident "palegreen" <- lexP; return palegreen } +++
+ do { Ident "paleturquoise" <- lexP; return paleturquoise } +++
+ do { Ident "palevioletred" <- lexP; return palevioletred } +++
+ do { Ident "papayawhip" <- lexP; return papayawhip } +++
+ do { Ident "peachpuff" <- lexP; return peachpuff } +++
+ do { Ident "peru" <- lexP; return peru } +++
+ do { Ident "pink" <- lexP; return pink } +++
+ do { Ident "plum" <- lexP; return plum } +++
+ do { Ident "powderblue" <- lexP; return powderblue } +++
+ do { Ident "purple" <- lexP; return purple } +++
+ do { Ident "red" <- lexP; return red } +++
+ do { Ident "rosybrown" <- lexP; return rosybrown } +++
+ do { Ident "royalblue" <- lexP; return royalblue } +++
+ do { Ident "saddlebrown" <- lexP; return saddlebrown } +++
+ do { Ident "salmon" <- lexP; return salmon } +++
+ do { Ident "sandybrown" <- lexP; return sandybrown } +++
+ do { Ident "seagreen" <- lexP; return seagreen } +++
+ do { Ident "seashell" <- lexP; return seashell } +++
+ do { Ident "sienna" <- lexP; return sienna } +++
+ do { Ident "silver" <- lexP; return silver } +++
+ do { Ident "skyblue" <- lexP; return skyblue } +++
+ do { Ident "slateblue" <- lexP; return slateblue } +++
+ do { Ident "slategray" <- lexP; return slategray } +++
+ do { Ident "snow" <- lexP; return snow } +++
+ do { Ident "springgreen" <- lexP; return springgreen } +++
+ do { Ident "steelblue" <- lexP; return steelblue } +++
+ do { Ident "teal" <- lexP; return teal } +++
+ do { Ident "thistle" <- lexP; return thistle } +++
+ do { Ident "tomato" <- lexP; return tomato } +++
+ do { Ident "turquoise" <- lexP; return turquoise } +++
+ do { Ident "violet" <- lexP; return violet } +++
+ do { Ident "wheat" <- lexP; return wheat } +++
+ do { Ident "white" <- lexP; return white } +++
+ do { Ident "whitesmoke" <- lexP; return whitesmoke } +++
+ do { Ident "yellow" <- lexP; return yellow } +++
+ do { Ident "yellowgreen" <- lexP; return yellowgreen } +++
+ do { Ident "dialoggray" <- lexP; return dialoggray } +++
+ parens
+ ( prec 10
+ ( do Ident "rgbColor" <- lexP
+ r <- step readPrec
+ g <- step readPrec
+ b <- step readPrec
+ return (rgbColor r g b)
+ )
+ ) +++
+ parens
+ ( prec 10
+ ( do Ident "cmyColor" <- lexP
+ r <- step readPrec
+ g <- step readPrec
+ b <- step readPrec
+ return (cmyColor r g b)
+ )
+ )
+
-- | Create a color from a red\/green\/blue triple.
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** Types.hs 2 May 2003 06:35:30 -0000 1.18
--- Types.hs 1 Jun 2003 13:00:10 -0000 1.19
***************
*** 162,166 ****
, py :: !Int -- ^ y component of a point.
}
! deriving (Eq,Show)
-- | Short function to construct a point.
--- 162,166 ----
, py :: !Int -- ^ y component of a point.
}
! deriving (Eq,Show,Read)
-- | Short function to construct a point.
***************
*** 206,210 ****
, sh :: !Int -- ^ the height of a size
}
! deriving (Eq,Show)
-- | Short function to construct a size
--- 206,210 ----
, sh :: !Int -- ^ the height of a size
}
! deriving (Eq,Show,Read)
-- | Short function to construct a size
***************
*** 253,257 ****
, vy :: !Int -- ^ delta-y component of a vector
}
! deriving (Eq,Show)
-- | Short function to construct a vector.
--- 253,257 ----
, vy :: !Int -- ^ delta-y component of a vector
}
! deriving (Eq,Show,Read)
-- | Short function to construct a vector.
***************
*** 755,759 ****
| JoinMiter -- ^ Leave it as is.
| JoinRound -- ^ Round off the corners.
! deriving (Eq,Show)
toCJoinStyle :: JoinStyle -> CInt
--- 755,759 ----
| JoinMiter -- ^ Leave it as is.
| JoinRound -- ^ Round off the corners.
! deriving (Eq,Show,Read)
toCJoinStyle :: JoinStyle -> CInt
***************
*** 769,773 ****
| CapSquare -- ^ Square: put a square at the logical end point.
| CapFlat -- ^ End flatly at the logical end point. (Doesn't stick out like square or round).
! deriving (Eq,Show)
toCCapStyle :: CapStyle -> CInt
--- 769,773 ----
| CapSquare -- ^ Square: put a square at the logical end point.
| CapFlat -- ^ End flatly at the logical end point. (Doesn't stick out like square or round).
! deriving (Eq,Show,Read)
toCCapStyle :: CapStyle -> CInt
***************
*** 786,790 ****
| LineDashDotDot -- ^ Dash - Dot - Dot pattern.
| LineCustomStyle [Word8] -- ^ Custom pattern: each element specifies the pixel length of a dash.
! deriving (Eq,Show)
withCLineStyle :: LineStyle -> (CInt -> CInt -> Ptr CUChar -> IO a) -> IO a
--- 786,790 ----
| LineDashDotDot -- ^ Dash - Dot - Dot pattern.
| LineCustomStyle [Word8] -- ^ Custom pattern: each element specifies the pixel length of a dash.
! deriving (Eq,Show,Read)
withCLineStyle :: LineStyle -> (CInt -> CInt -> Ptr CUChar -> IO a) -> IO a
|
|
From: <kr_...@us...> - 2003-06-01 09:42:34
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv29464/src/Graphics/UI/GIO
Modified Files:
Font.hs
Log Message:
remove getFormDefs function
Index: Font.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Font.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Font.hs 30 Jan 2003 21:54:49 -0000 1.1
--- Font.hs 1 Jun 2003 09:42:31 -0000 1.2
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Font
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Font
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 19,23 ****
-- * Enumerate
! , getFontNames, getFontDefs, getFontVariants
-- * Standard font definitions.
--- 19,23 ----
-- * Enumerate
! , getFontNames, getFontVariants
-- * Standard font definitions.
***************
*** 31,54 ****
) where
-
- import Data.FiniteMap( fmToList )
- import Graphics.UI.GIO.Types
import Graphics.UI.Port.Font
-
- {--------------------------------------------------------------------
-
- --------------------------------------------------------------------}
- -- | Return all available font definitions of a certain font between
- -- a minimum and maximum size. The 'fontStrikeOut' and 'fontUnderline'
- -- members are always 'False'. (see also 'getFontVariants').
- getFontDefs :: FontName -> FontSize -> FontSize -> IO [FontDef]
- getFontDefs name min max
- = do fm <- getFontVariants name min max
- return (concat (map toFontDef (fmToList fm)))
- where
- toFontDef ((weight,style),sizes)
- = [FontDef name size weight style False False | size <- sizes]
-
- {--------------------------------------------------------------------
-
- --------------------------------------------------------------------}
--- 31,33 ----
|
|
From: <kr_...@us...> - 2003-05-31 19:08:41
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv5199/src/Graphics/UI/GIO
Modified Files:
Canvas.hs
Log Message:
Added rotate, scale, translate and shearCanvas
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Canvas.hs 30 May 2003 21:55:06 -0000 1.10
--- Canvas.hs 31 May 2003 19:08:37 -0000 1.11
***************
*** 52,55 ****
--- 52,61 ----
, drawBitmap
+ -- * Transform
+ , rotateCanvas
+ , scaleCanvas
+ , shearCanvas
+ , translateCanvas
+
-- * Font metrics
, fontMetrics
***************
*** 225,226 ****
--- 231,252 ----
drawBitmap :: Point -> Bitmap -> Canvas -> IO ()
drawBitmap p bitmap can = Port.drawBitmap p bitmap (hcanvas can)
+
+ --------------------------------------------------------------------
+ -- Transformations
+ --------------------------------------------------------------------
+
+ -- | Rotate the canvas clockwise with an angle in radians.
+ rotateCanvas :: Double -> Canvas -> IO ()
+ rotateCanvas angle can = Port.rotateCanvas angle (hcanvas can)
+
+ -- | Scale the canvas with a horizontal and vertical factor.
+ scaleCanvas :: Double -> Double -> Canvas -> IO ()
+ scaleCanvas sx sy can = Port.scaleCanvas sx sy (hcanvas can)
+
+ -- | Shear the canvas in a horizontal and vertical direction.
+ shearCanvas :: Double -> Double -> Canvas -> IO ()
+ shearCanvas sx sy can = Port.shearCanvas sx sy (hcanvas can)
+
+ -- | Translate (or move) the canvas in a horizontal and vertical direction.
+ translateCanvas :: Double -> Double -> Canvas -> IO ()
+ translateCanvas dx dy can = Port.translateCanvas dx dy (hcanvas can)
|
|
From: <kr_...@us...> - 2003-05-30 22:07:35
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv13786/src/Graphics/UI/GIO
Modified Files:
Attributes.hs Bitmap.hs Canvas.hs Window.hs
Log Message:
The bufferMode is added to Drawn class. Added functions drawInBitmap and drawInWindow functions.
Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** Attributes.hs 30 May 2003 13:07:05 -0000 1.11
--- Attributes.hs 30 May 2003 21:55:06 -0000 1.12
***************
*** 52,56 ****
-- ** Drawn
! , Drawn, pen, color, bgcolor, hatch
, thickness, capstyle, linestyle, joinstyle
--- 52,57 ----
-- ** Drawn
! , Drawn, bufferMode, pen
! , color, bgcolor, hatch
, thickness, capstyle, linestyle, joinstyle
***************
*** 221,224 ****
--- 222,231 ----
class HasFont w => Drawn w where
+
+ -- | The buffering mode. If the window is buffered then all
+ -- drawing operations are first performed to memory buffer and after
+ -- that the buffer is copied to the output device.
+ bufferMode :: Attr w BufferMode
+
-- | The pen
pen :: Attr w Pen
***************
*** 257,260 ****
--- 264,268 ----
bkDrawMode :: Attr w Bool
bkDrawMode = mapAttr penBkDrawMode (\pen m -> pen{penBkDrawMode=m}) pen
+
-- | Widgets with a title.
Index: Bitmap.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Bitmap.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Bitmap.hs 7 Apr 2003 21:03:10 -0000 1.2
--- Bitmap.hs 30 May 2003 21:55:06 -0000 1.3
***************
*** 52,57 ****
frame = newAttr (\b -> do sz <- Lib.getBitmapSize b; return (rectOfSize sz))
(\b r -> do Lib.setBitmapSize b (rectSize r))
-
- {--------------------------------------------------------------------
-
- --------------------------------------------------------------------}
--- 52,53 ----
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Canvas.hs 30 May 2003 11:39:08 -0000 1.9
--- Canvas.hs 30 May 2003 21:55:06 -0000 1.10
***************
*** 31,34 ****
--- 31,36 ----
Canvas, CanvasPen, Pen(..)
, setCanvasPen, getCanvasPen
+
+ , drawInBitmap
-- * Drawing primitives
***************
*** 77,86 ****
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
}
! newtype CanvasPen = CanvasPen (Var Pen)
instance Drawn CanvasPen where
! pen = newAttr (\(CanvasPen vpen) -> getVar vpen)
! (\(CanvasPen vpen) -> setVar vpen)
instance HasFont CanvasPen where
--- 79,91 ----
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
+ , vmode :: BufferMode
}
! data CanvasPen = CanvasPen (Var Pen) BufferMode
instance Drawn CanvasPen where
! pen = newAttr (\(CanvasPen vpen _) -> getVar vpen)
! (\(CanvasPen vpen _) -> setVar vpen)
!
! bufferMode = readAttr "bufferMode" (\(CanvasPen _ vmode) -> return vmode)
instance HasFont CanvasPen where
***************
*** 88,102 ****
setCanvasPen :: Canvas -> [Prop CanvasPen] -> IO ()
! setCanvasPen (Canvas handle vpen) props = do
! set (CanvasPen vpen) props
pen <- getVar vpen
Port.changeCanvasPen pen handle
getCanvasPen :: Canvas -> Attr CanvasPen a -> IO a
! getCanvasPen (Canvas handle vpen) = get (CanvasPen vpen)
!
! -- | The current font.
! penfont :: Attr CanvasPen Font
! penfont = mapAttr penFont (\pen c -> pen{penFont=c}) pen
-- | The font metrics (read-only).
--- 93,104 ----
setCanvasPen :: Canvas -> [Prop CanvasPen] -> IO ()
! setCanvasPen (Canvas handle vpen vmode) props = do
! set (CanvasPen vpen vmode) props
pen <- getVar vpen
Port.changeCanvasPen pen handle
getCanvasPen :: Canvas -> Attr CanvasPen a -> IO a
! getCanvasPen (Canvas handle vpen vmode) = get (CanvasPen vpen vmode)
!
-- | The font metrics (read-only).
***************
*** 139,143 ****
withCanvas bmode pen handle f
= do vpen <- newVar pen
! Port.withCanvas pen bmode handle (f (Canvas handle vpen))
--------------------------------------------------------------------
--- 141,151 ----
withCanvas bmode pen handle f
= do vpen <- newVar pen
! Port.withCanvas pen bmode handle (f (Canvas handle vpen bmode))
!
! -- | The drawInBitmap executes the given function with canvas
! -- associated with given Bitmap.
! drawInBitmap :: BufferMode -> Pen -> Bitmap -> (Canvas -> IO a) -> IO a
! drawInBitmap bmode pen bmp f = do
! Port.drawInBitmap bmp (\hcanvas -> withCanvas bmode pen hcanvas f)
--------------------------------------------------------------------
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** Window.hs 30 May 2003 11:39:09 -0000 1.16
--- Window.hs 30 May 2003 21:55:07 -0000 1.17
***************
*** 14,17 ****
--- 14,18 ----
( Window, window, domain, resizeable, view, layout, autosize, bufferMode
, dialog, runDialog
+ , drawInWindow
-- * Internal
, hwindow
***************
*** 138,147 ****
(\w sz-> Lib.setWindowViewSize (hwindow w) sz)
- -- | The buffering mode for Window. If the window is buffered then all
- -- drawing operations are first performed to memory buffer and after
- -- that the buffer is copied to the screen.
- bufferMode :: Attr Window BufferMode
- bufferMode = newAttr (getVar . vbufferMode) (setVar . vbufferMode)
-
instance Dismissible Window where
dismissWidget w = Lib.dismissWindow (hwindow w)
--- 139,142 ----
***************
*** 159,162 ****
--- 154,159 ----
pen = newAttr (getVar . vpen) (\w pen -> setVar (vpen w) pen >> recolorWindow w)
+ bufferMode = newAttr (getVar . vbufferMode) (setVar . vbufferMode)
+
instance HasFont Window where
font = mapAttr penFont (\pen c -> pen{penFont=c}) pen
***************
*** 201,203 ****
layout :: Control c => Attr Window c
layout
! = writeAttr "layout" (\w c -> do setVar (vlayout w) (pack c); relayoutWindow w)
\ No newline at end of file
--- 198,207 ----
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.
! drawInWindow :: BufferMode -> Window -> (Canvas -> IO a) -> IO a
! drawInWindow bmode w f = do
! pen <- get w pen
! Lib.drawInWindow (hwindow w) (\hcanvas -> withCanvas bmode pen hcanvas f)
|
|
From: <kr_...@us...> - 2003-05-30 21:46:51
|
Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv9917/src/Port
Modified Files:
Bitmap.hs Canvas.hs Window.hs
Log Message:
Replace getWindowCanvas and releaseWindowCanvas functions with drawInWindow function.
Index: Bitmap.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Bitmap.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Bitmap.hs 7 Apr 2003 20:58:48 -0000 1.5
--- Bitmap.hs 30 May 2003 21:46:47 -0000 1.6
***************
*** 85,88 ****
--- 85,89 ----
-- | Draw to a bitmap.
+ -- The function passed to drawInWindow should be wrapped with 'withCanvas' function.
drawInBitmap :: Bitmap -> (CanvasHandle -> IO a) -> IO a
drawInBitmap bitmap f
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Canvas.hs,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** Canvas.hs 15 Mar 2003 01:06:32 -0000 1.13
--- Canvas.hs 30 May 2003 21:46:47 -0000 1.14
***************
*** 14,18 ****
module Graphics.UI.Port.Canvas
( -- * Canvas
! initCanvas, doneCanvas
, changeCanvasPen
--- 14,18 ----
module Graphics.UI.Port.Canvas
( -- * Canvas
! withCanvas
, changeCanvasPen
***************
*** 99,108 ****
-- | Initialize a canvas and it's initial drawing pencil. Should be called before using
-- any of the drawing operations.
! initCanvas :: Pen -> BufferMode -> CanvasHandle -> IO ()
! initCanvas pen buffermode canvas
! = withCFont (penFont pen) $ \cfont ->
! withCLineStyle (penLineStyle pen) $ \cline clinecount clinestyles ->
! withCHatchStyle (penHatchStyle pen) $ \chatch chatchbmp ->
! osInitCanvas (toCInt (penSize pen))
(toCDrawMode (penMode pen))
(toCColor (penColor pen))
--- 99,108 ----
-- | Initialize a canvas and it's initial drawing pencil. Should be called before using
-- any of the drawing operations.
! withCanvas :: Pen -> BufferMode -> CanvasHandle -> IO a -> IO a
! withCanvas pen buffermode canvas action = do
! (withCFont (penFont pen) $ \cfont ->
! withCLineStyle (penLineStyle pen) $ \cline clinecount clinestyles ->
! withCHatchStyle (penHatchStyle pen) $ \chatch chatchbmp ->
! osInitCanvas (toCInt (penSize pen))
(toCDrawMode (penMode pen))
(toCColor (penColor pen))
***************
*** 115,119 ****
cfont
canvas
! (toCBufferMode buffermode)
foreign import ccall osInitCanvas :: CInt -> CInt -> CColor -> CColor
--- 115,122 ----
cfont
canvas
! (toCBufferMode buffermode))
! r <- action
! osDoneCanvas canvas
! return r
foreign import ccall osInitCanvas :: CInt -> CInt -> CColor -> CColor
***************
*** 127,131 ****
-- | Release any resources associated with the canvas. Must be called
-- after 'initCanvas', when all drawing operations have been performed.
! foreign import ccall "osDoneCanvas" doneCanvas :: CanvasHandle -> IO ()
--- 130,134 ----
-- | Release any resources associated with the canvas. Must be called
-- after 'initCanvas', when all drawing operations have been performed.
! foreign import ccall osDoneCanvas :: CanvasHandle -> IO ()
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Window.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Window.hs 27 Apr 2003 18:19:13 -0000 1.10
--- Window.hs 30 May 2003 21:46:47 -0000 1.11
***************
*** 2,9 ****
-----------------------------------------------------------------------------------------
{-| Module : Window
! Copyright : (c) Krasimir Angelov & Daan Leijen 2003
License : BSD-style
! Maintainer : ka2...@ya... & da...@cs...
Stability : provisional
Portability : portable
--- 2,9 ----
-----------------------------------------------------------------------------------------
{-| Module : Window
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 33,39 ****
, setWindowLineSize, getWindowLineSize
, setWindowEnabled, getWindowEnabled
! -- * Canvas
! , getWindowCanvasHandle
! , releaseWindowCanvasHandle
) where
--- 33,38 ----
, setWindowLineSize, getWindowLineSize
, setWindowEnabled, getWindowEnabled
! -- * Drawing
! , drawInWindow
) where
***************
*** 41,44 ****
--- 40,44 ----
import Foreign.Ptr
import Foreign.Marshal.Alloc
+ import System.IO( bracket )
import System.IO.Unsafe( unsafePerformIO )
import Control.Concurrent.MVar
***************
*** 46,50 ****
import Graphics.UI.Port.PtrMap
import Graphics.UI.Port.Types
! import Graphics.UI.Port.Canvas(initCanvas, doneCanvas, defaultPen, dialogPen)
import Graphics.UI.Port.Handlers( getAllWindowHandles, registerWindow, setWindowDismissHandler, setWindowPaintHandler )
--- 46,50 ----
import Graphics.UI.Port.PtrMap
import Graphics.UI.Port.Types
! import Graphics.UI.Port.Canvas(withCanvas, defaultPen, dialogPen)
import Graphics.UI.Port.Handlers( getAllWindowHandles, registerWindow, setWindowDismissHandler, setWindowPaintHandler )
***************
*** 87,93 ****
return hwnd
where
! onpaint canvas rect = do
! initCanvas defaultPen UnBuffered canvas
! doneCanvas canvas
foreign import ccall osCreateWindow :: IO WindowHandle
--- 87,91 ----
return hwnd
where
! onpaint canvas rect = withCanvas defaultPen UnBuffered canvas (return ())
foreign import ccall osCreateWindow :: IO WindowHandle
***************
*** 104,110 ****
return hwnd
where
! onpaint canvas rect = do
! initCanvas dialogPen UnBuffered canvas
! doneCanvas canvas
foreign import ccall osCreateDialog :: WindowHandle -> IO WindowHandle
--- 102,106 ----
return hwnd
where
! onpaint canvas rect = withCanvas dialogPen UnBuffered canvas (return ())
foreign import ccall osCreateDialog :: WindowHandle -> IO WindowHandle
***************
*** 223,230 ****
foreign import ccall unsafe "osGetWindowEnabled" getWindowEnabled :: WindowHandle -> IO Bool
! -- | Get a canvas handle to draw directly on the window. In general however, one should
-- register a paint event handler for drawing in a window ('registerWindowPaint').
! foreign import ccall "osGetWindowCanvas" getWindowCanvasHandle :: WindowHandle -> IO CanvasHandle
!
! -- | Release a canvas handle that was obtained through 'getWindowCanvasHandle'.
! foreign import ccall "osReleaseWindowCanvas" releaseWindowCanvasHandle :: WindowHandle -> CanvasHandle -> IO ()
--- 219,227 ----
foreign import ccall unsafe "osGetWindowEnabled" getWindowEnabled :: WindowHandle -> IO Bool
! -- | Draw directly on the window. In general however, one should
-- register a paint event handler for drawing in a window ('registerWindowPaint').
! -- The function passed to drawInWindow should be wrapped with 'withCanvas' function.
! drawInWindow :: WindowHandle -> (CanvasHandle -> IO a) -> IO a
! drawInWindow hwindow f = bracket (osGetWindowCanvas hwindow) (osReleaseWindowCanvas hwindow) f
! foreign import ccall osGetWindowCanvas :: WindowHandle -> IO CanvasHandle
! foreign import ccall osReleaseWindowCanvas :: WindowHandle -> CanvasHandle -> IO ()
|
|
From: <kr_...@us...> - 2003-05-30 13:07:10
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv22412/src/Graphics/UI/GIO
Modified Files:
Attributes.hs Controls.hs
Log Message:
Added RangedSelect class and his instances for ProgressBar and Slider controls
Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Attributes.hs 30 May 2003 11:39:08 -0000 1.10
--- Attributes.hs 30 May 2003 13:07:05 -0000 1.11
***************
*** 75,78 ****
--- 75,79 ----
, SingleSelect, selected
, MultiSelect, selection
+ , RangedSelect, range, selectedPos
-- * Internal
***************
*** 299,300 ****
--- 300,308 ----
selection :: Attr w [Int]
+ -- | Widgets that selects integer position inside the specified range.
+ class RangedSelect w where
+ -- | The selection range
+ range :: Attr w (Int, Int)
+
+ -- | The selected position
+ selectedPos :: Attr w Int
Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Controls.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -d -r1.11 -r1.12
*** Controls.hs 30 May 2003 11:39:08 -0000 1.11
--- Controls.hs 30 May 2003 13:07:05 -0000 1.12
***************
*** 17,22 ****
, Entry, entry, readOnly, visible
, Popup, popup
! , Slider, hslider, vslider, sliderRange, sliderPos
! , ProgressBar, hProgressBar, vProgressBar, progressRange, progressPos
, CheckGroup, checkGroup, checkLayout
, RadioGroup, radioGroup, radioLayout
--- 17,22 ----
, Entry, entry, readOnly, visible
, Popup, popup
! , Slider, hslider, vslider
! , ProgressBar, hProgressBar, vProgressBar
, CheckGroup, checkGroup, checkLayout
, RadioGroup, radioGroup, radioLayout
***************
*** 448,460 ****
return r
! sliderRange :: Attr Slider (Int,Int)
! sliderRange
! = newAttr (\w -> Port.getSliderRange (shandle w))
! (\w (min,max) -> Port.setSliderRange (shandle w) min max)
!
! sliderPos :: Attr Slider Int
! sliderPos
! = newAttr (Port.getSliderPosition . shandle)
! (Port.setSliderPosition . shandle)
instance Commanding Slider where
--- 448,458 ----
return r
! instance RangedSelect Slider where
! range = newAttr (\w -> Port.getSliderRange (shandle w))
! (\w (min,max) -> Port.setSliderRange (shandle w) min max)
!
! selectedPos
! = newAttr (Port.getSliderPosition . shandle)
! (Port.setSliderPosition . shandle)
instance Commanding Slider where
***************
*** 498,517 ****
return r
! progressRange :: Attr ProgressBar (Int,Int)
! progressRange
! = newAttr (\w -> getVar (pbrange w))
! (\w r@(min,max) -> do
! pos <- Port.getProgressBarFraction (pbhandle w) min max
! Port.setProgressBarFraction (pbhandle w) min max pos
! setVar (pbrange w) r)
! progressPos :: Attr ProgressBar Int
! progressPos
! = newAttr (\w -> do
! (min,max) <- getVar (pbrange w)
! Port.getProgressBarFraction (pbhandle w) min max)
! (\w pos -> do
! (min,max) <- getVar (pbrange w)
! Port.setProgressBarFraction (pbhandle w) min max pos)
instance Control ProgressBar where
--- 496,513 ----
return r
! instance RangedSelect ProgressBar where
! range = newAttr (\w -> getVar (pbrange w))
! (\w r@(min,max) -> do
! pos <- Port.getProgressBarFraction (pbhandle w) min max
! Port.setProgressBarFraction (pbhandle w) min max pos
! setVar (pbrange w) r)
! selectedPos
! = newAttr (\w -> do
! (min,max) <- getVar (pbrange w)
! Port.getProgressBarFraction (pbhandle w) min max)
! (\w pos -> do
! (min,max) <- getVar (pbrange w)
! Port.setProgressBarFraction (pbhandle w) min max pos)
instance Control ProgressBar where
|
|
From: <kr_...@us...> - 2003-05-30 13:07:10
|
Update of /cvsroot/htoolkit/gio/src/examples/simple In directory sc8-pr-cvs1:/tmp/cvs-serv22412/src/examples/simple Modified Files: Progress.hs Log Message: Added RangedSelect class and his instances for ProgressBar and Slider controls Index: Progress.hs =================================================================== RCS file: /cvsroot/htoolkit/gio/src/examples/simple/Progress.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Progress.hs 2 Apr 2003 21:33:55 -0000 1.2 --- Progress.hs 30 May 2003 13:07:06 -0000 1.3 *************** *** 3,7 **** import Graphics.UI.GIO ! main = start SDI [] demo maxSpeed = 200 :: Int --- 3,7 ---- import Graphics.UI.GIO ! main = start "Progress" "1.0" SDI [] demo maxSpeed = 200 :: Int *************** *** 9,21 **** demo = do ! w <- window [title =: "Progress", view =: sz 800 100, domain =: sz 800 80] tm <- timer [interval =: maxSpeed `div` 2] ! prg <- hProgressBar True [progressRange =: (0,maxProgress)] w ! lbl <- label [text =: "Speed"] w ! sld <- hslider [sliderRange =: (0,maxSpeed), sliderPos =: maxSpeed `div` 2] w set w [layout =: (hfill prg ^^^ (lbl <<< hfill sld))] ! set tm [on command =: set prg [progressPos ~: next]] set sld [on command =: changeSpeed tm sld] ! set w [on destroy =: destroyTimer tm] return () where --- 9,21 ---- 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 *************** *** 24,27 **** changeSpeed tm sld = do ! pos <- get sld sliderPos set tm [interval =: maxSpeed-pos+20] --- 24,27 ---- changeSpeed tm sld = do ! pos <- get sld selectedPos set tm [interval =: maxSpeed-pos+20] |
|
From: <kr_...@us...> - 2003-05-30 12:07:39
|
Update of /cvsroot/htoolkit/gio/src/examples/simple
In directory sc8-pr-cvs1:/tmp/cvs-serv12556
Modified Files:
BitmapViewer.hs BouncingBalls.hs SimpleDrawing.hs
Log Message:
Update samples after changes in Canvas API
Index: BitmapViewer.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/BitmapViewer.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** BitmapViewer.hs 26 Apr 2003 21:05:44 -0000 1.6
--- BitmapViewer.hs 30 May 2003 11:58:16 -0000 1.7
***************
*** 10,14 ****
main
! = start MDI [title =: "Bitmap Viewer"] $
do mfile <- menu [title =: "&File"] mainMenu
mopen <- menuitem [title =: "&Open"] mfile
--- 10,14 ----
main
! = start "Bitmap Viewer" "1.0" MDI [] $
do mfile <- menu [title =: "&File"] mainMenu
mopen <- menuitem [title =: "&Open"] mfile
***************
*** 31,35 ****
paintImage image can updFrame updAreas
! = do bitmap (pt 0 0) image can
openBitmapWindow mclose fname = do
--- 31,35 ----
paintImage image can updFrame updAreas
! = do drawBitmap (pt 0 0) image can
openBitmapWindow mclose fname = do
Index: BouncingBalls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/BouncingBalls.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** BouncingBalls.hs 2 Apr 2003 21:33:55 -0000 1.3
--- BouncingBalls.hs 30 May 2003 11:58:16 -0000 1.4
***************
*** 4,13 ****
main
! = start SDI [] balls
balls
= do vballs <- newVar []
! w <- window [title =: "Bouncing balls", resizeable =: True, view =: sz maxX maxY]
set w [ on paint =: paintBalls vballs
, on click =: dropBall w vballs
--- 4,13 ----
main
! = start "Bouncing balls" "1.0" SDI [] balls
balls
= do vballs <- newVar []
! w <- window [resizeable =: True, view =: sz maxX maxY]
set w [ on paint =: paintBalls vballs
, on click =: dropBall w vballs
***************
*** 40,50 ****
paintBalls vballs can updframe updareas
! = do box updframe [color =: lightgray] can
balls <- getVar vballs
mapM_ (drawBall can) (map head (filter (not.null) balls))
drawBall can pt
! = do oval pt radius radius [color =: red] can
! ellipse pt radius radius [] can
--- 40,53 ----
paintBalls vballs can updframe updareas
! = do setCanvasPen can [color =: lightgray]
! fillRect updframe can
balls <- getVar vballs
mapM_ (drawBall can) (map head (filter (not.null) balls))
drawBall can pt
! = do setCanvasPen can [color =: red]
! fillEllipse pt radius radius can
! setCanvasPen can [color =: black]
! drawEllipse pt radius radius can
Index: SimpleDrawing.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/examples/simple/SimpleDrawing.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** SimpleDrawing.hs 2 Apr 2003 21:33:55 -0000 1.4
--- SimpleDrawing.hs 30 May 2003 11:58:16 -0000 1.5
***************
*** 4,34 ****
main
! = start SDI [] $
! do w <- window [title =: "Hello world", width =: 600, height =: 600
! ,on paint =: mypaint
]
set w [on motion =: \p -> set w [title =: ("mouse is at " ++ show p)]]
where
! mypaint c updFrame updArea
! = do rectangle (rect (pt 50 50) (pt 200 200)) [thickness =: 10, color =: blue] c
! polyline [pt 150 250,pt 50 300,pt 200 300] [color =: red] c
! ellipse (pt 100 375) 50 25 [color=:green, thickness =: 5] c
! arc (pt 100 450) 50 25 0 (0.5*pi) [color=:red, thickness=:5] c
! box (rect (pt 250 50) (pt 450 200)) [color =: red] c
! polygon [pt 350 250,pt 250 300,pt 400 300] [color =: red] c
! oval (pt 300 375) 50 25 [color=:green] c
! pie (pt 300 450) 50 25 0 (0.5*pi) [color=:red] c
!
! line (pt 30 30) (pt 200 150) [thickness =: 15, color =: magenta] c
! disc (pt 70 70) 10 [color =: yellow] c
! circle (pt 70 70) 10 [color =: black] c
!
! write (pt 100 100) [text =: "Some text", color =: blue] c
!
! sserif14b <- (createFont (sansSerifFontDef{ fontSize = 14, fontWeight = fontBoldWeight })
! `catch` \err -> return defaultFont)
! write (pt 120 120) [text =: "14pt bold sans serif text", color =: black, font =: sserif14b ] c
--- 4,47 ----
main
! = start "SimpleDrawing" "1.0" SDI [] $
! do sserif14b <- createFont (sansSerifFontDef{fontSize = 14, fontWeight = fontBoldWeight})
! w <- window [title =: "Hello world", width =: 600, height =: 600
! ,on paint =: mypaint sserif14b
]
set w [on motion =: \p -> set w [title =: ("mouse is at " ++ show p)]]
where
! mypaint sserif14b c updFrame updArea
! = do setCanvasPen c [thickness =: 10, color =: blue]
! drawRect (rect (pt 50 50) (pt 200 200)) c
! setCanvasPen c [color =: red]
! drawPolyline [pt 150 250,pt 50 300,pt 200 300] c
!
! setCanvasPen c [color=:green, thickness =: 5]
! drawEllipse (pt 100 375) 50 25 c
!
! setCanvasPen c [color=:red]
! drawArc (pt 100 450) 50 25 0 (0.5*pi) c
! fillRect (rect (pt 250 50) (pt 450 200)) c
! drawPolygon [pt 350 250,pt 250 300,pt 400 300] c
!
! setCanvasPen c [color=:green]
! fillEllipse (pt 300 375) 50 25 c
!
! setCanvasPen c [color=:red]
! fillPie (pt 300 450) 50 25 0 (0.5*pi) c
+ setCanvasPen c [thickness =: 15, color =: magenta]
+ drawLine (pt 30 30) (pt 200 150) c
+
+ setCanvasPen c [color =: yellow]
+ fillCircle (pt 70 70) 10 c
+ setCanvasPen c [color =: black]
+ drawCircle (pt 70 70) 10 c
+ setCanvasPen c [color =: blue]
+ drawString (pt 100 100) "Some text" c
+
+ setCanvasPen c [color =: black, font =: sserif14b]
+ drawString (pt 120 120) "14pt bold sans serif text" c
|
|
From: <kr_...@us...> - 2003-05-30 11:43:02
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv27279/src/Graphics/UI/GIO
Modified Files:
Attributes.hs Canvas.hs Controls.hs Types.hs Window.hs
Log Message:
The high level canvas API is rewritten to get better performance
Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Attributes.hs 23 Apr 2003 21:48:46 -0000 1.9
--- Attributes.hs 30 May 2003 11:39:08 -0000 1.10
***************
*** 48,67 ****
, frame, position, size, width, height
! -- ** Colored
! , Colored, color
!
! -- ** Background
! , Background, bgcolor
! , Filled, hatch
!
! -- ** Literate
! , Literate, text, font
-- ** Titled
, Titled, title
- -- ** Drawn
- , Drawn, thickness
-
-- ** Able
, Able, enabled
--- 48,61 ----
, frame, position, size, width, height
! -- ** HasFont
! , HasFont, font
!
! -- ** Drawn
! , Drawn, pen, color, bgcolor, hatch
! , thickness, capstyle, linestyle, joinstyle
-- ** Titled
, Titled, title
-- ** Able
, Able, enabled
***************
*** 219,258 ****
height :: Attr w Int
height = mapAttr (\(Size w h) -> h) (\(Size w _) h -> Size w h) size
- -- | Widgets with a foreground color.
- class Colored w where
-- | The (fore ground) color of the widget.
color :: Attr w Color
!
! -- | Widgets with a background color.
! class Background w where
-- | The back ground color.
bgcolor :: Attr w Color
- -- | Widgets that can be filled with a pattern.
- class Filled w where
-- | The hatch style.
hatch :: Attr w HatchStyle
- -- | Objects that are drawn.
- class Drawn w where
-- | The thickness of the drawing pencil.
thickness :: Attr w Int
! {-
-- | The cap style.
capstyle :: Attr w CapStyle
-- | The line style.
linestyle :: Attr w LineStyle
-- | The join style.
joinstyle :: Attr w JoinStyle
! -}
!
! -- | Widgets with a text.
! class Literate w where
! -- | The text.
! text :: Attr w String
! -- | The font.
! font :: Attr w Font
-- | Widgets with a title.
class Titled w where
--- 213,260 ----
height :: Attr w Int
height = mapAttr (\(Size w h) -> h) (\(Size w _) h -> Size w h) size
+
+ -- | Widgets with a font.
+ class HasFont w where
+ -- | The font.
+ font :: Attr w Font
+
+ class HasFont w => Drawn w where
+ -- | The pen
+ pen :: Attr w Pen
-- | The (fore ground) color of the widget.
color :: Attr w Color
! color = mapAttr penColor (\pen c -> pen{penColor=c}) pen
!
-- | The back ground color.
bgcolor :: Attr w Color
+ bgcolor = mapAttr penBackColor (\pen c -> pen{penBackColor=c}) pen
-- | The hatch style.
hatch :: Attr w HatchStyle
+ hatch = mapAttr penHatchStyle (\pen h -> pen{penHatchStyle=h}) pen
-- | The thickness of the drawing pencil.
thickness :: Attr w Int
! thickness = mapAttr penSize (\pen n -> pen{penSize=n}) pen
!
-- | The cap style.
capstyle :: Attr w CapStyle
+ capstyle = mapAttr penCapStyle (\pen s -> pen{penCapStyle=s}) pen
+
-- | The line style.
linestyle :: Attr w LineStyle
+ linestyle = mapAttr penLineStyle (\pen s -> pen{penLineStyle=s}) pen
+
-- | The join style.
joinstyle :: Attr w JoinStyle
! joinstyle = mapAttr penJoinStyle (\pen s -> pen{penJoinStyle=s}) pen
!
! drawMode :: Attr w DrawMode
! drawMode = mapAttr penMode (\pen m -> pen{penMode=m}) pen
+ bkDrawMode :: Attr w Bool
+ bkDrawMode = mapAttr penBkDrawMode (\pen m -> pen{penBkDrawMode=m}) pen
+
-- | Widgets with a title.
class Titled w where
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** Canvas.hs 30 May 2003 08:23:08 -0000 1.8
--- Canvas.hs 30 May 2003 11:39:08 -0000 1.9
***************
*** 1,8 ****
-----------------------------------------------------------------------------------------
{-| Module : Canvas
! Copyright : (c) Daan Leijen 2003
License : BSD-style
! Maintainer : da...@cs...
Stability : provisional
Portability : portable
--- 1,8 ----
-----------------------------------------------------------------------------------------
{-| Module : Canvas
! Copyright : (c) Krasimir Angelov 2003
License : BSD-style
! Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
***************
*** 16,28 ****
> where
> mypaint canvas updateFrame updateAreas
! > = do box (rect (pt 10 10) (pt 20 20)) [color =: red] canvas
! > line (pt 20 20) (pt 30 30) [color =: blue, thickness =: 10] canvas
A paint function (of type 'PaintFunction') takes three arguments, the canvas
(of type 'Canvas'), the bounding rectangle of the update frame and all areas that
need to be repainted.
-
- On a canvas, you can draw objects. These objects can be either solid objects, like
- 'box' and 'disc', or figures like 'rectangle' and 'circle'.
-}
-----------------------------------------------------------------------------------------
--- 16,27 ----
> where
> mypaint canvas updateFrame updateAreas
! > = do setCanvasPen canvas [color =: red]
! > fillRect (rect (pt 10 10) (pt 20 20)) canvas
! > setCanvasPen canvas [color =: blue, thickness =: 10]
! > drawLine (pt 20 20) (pt 30 30) canvas
A paint function (of type 'PaintFunction') takes three arguments, the canvas
(of type 'Canvas'), the bounding rectangle of the update frame and all areas that
need to be repainted.
-}
-----------------------------------------------------------------------------------------
***************
*** 30,56 ****
(
-- * Canvas
! Canvas, Pen(..)
! , pen, pencolor, penthickness, penfont
!
! -- * Canvas items
! -- ** Solids
! , Box, box
! , Oval, oval, disc
! , Pie, pie
! , Polygon, polygon
!
! -- ** Figures
! , Line, line
! , Rectangle, rectangle
! , Ellipse, ellipse, circle
! , Arc, arc
! , Polyline, polyline
! -- ** Text
! , Write, write
- -- ** Bitmaps
- , bitmap
-
-- * Font metrics
, fontMetrics
--- 29,53 ----
(
-- * Canvas
! Canvas, CanvasPen, Pen(..)
! , setCanvasPen, getCanvasPen
! -- * Drawing primitives
! , drawString
! , drawLine
! , drawPolyline
! , drawRect
! , fillRect
! , drawOval
! , drawEllipse
! , drawCircle
! , fillOval
! , fillEllipse
! , fillCircle
! , drawCurve
! , drawArc
! , fillPie
! , drawPolygon
! , drawBitmap
-- * Font metrics
, fontMetrics
***************
*** 58,64 ****
, fontStringWidth
! , penfontMetrics
! , penfontCharWidth
! , penfontStringWidth
-- * Internal
--- 55,61 ----
, fontStringWidth
! , canvasFontMetrics
! , canvasFontCharWidth
! , canvasFontStringWidth
-- * Internal
***************
*** 73,111 ****
import Control.Monad( when )
! {--------------------------------------------------------------------
! Classes
! --------------------------------------------------------------------}
- {--------------------------------------------------------------------
-
- --------------------------------------------------------------------}
-- | A canvas is an area on which you can draw objects.
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
}
! -- | The current drawing pencil.
! pen :: Attr Canvas Pen
! pen = newAttr getter setter
! where
! getter c = getVar (vpen c)
! setter c p = do oldpen <- takeVar (vpen c)
! when (p /= oldpen) (Port.changeCanvasPen p (hcanvas c))
! putVar (vpen c) p
! -- | The current drawing color.
! pencolor :: Attr Canvas Color
! pencolor
! = attrPenColor pen
! -- | The current pencil size.
! penthickness :: Attr Canvas Int
! penthickness
! = attrPenThickness pen
-- | The current font.
! penfont :: Attr Canvas Font
! penfont
! = attrPenFont pen
-- | The font metrics (read-only).
--- 70,102 ----
import Control.Monad( when )
! --------------------------------------------------------------------
! -- Canvas
! --------------------------------------------------------------------
-- | A canvas is an area on which you can draw objects.
data Canvas = Canvas{ hcanvas :: CanvasHandle
, vpen :: Var Pen
}
+ newtype CanvasPen = CanvasPen (Var Pen)
! instance Drawn CanvasPen where
! pen = newAttr (\(CanvasPen vpen) -> getVar vpen)
! (\(CanvasPen vpen) -> setVar vpen)
! instance HasFont CanvasPen where
! font = mapAttr penFont (\pen c -> pen{penFont=c}) pen
! setCanvasPen :: Canvas -> [Prop CanvasPen] -> IO ()
! setCanvasPen (Canvas handle vpen) props = do
! set (CanvasPen vpen) props
! pen <- getVar vpen
! Port.changeCanvasPen pen handle
+ getCanvasPen :: Canvas -> Attr CanvasPen a -> IO a
+ getCanvasPen (Canvas handle vpen) = get (CanvasPen vpen)
+
-- | The current font.
! penfont :: Attr CanvasPen Font
! penfont = mapAttr penFont (\pen c -> pen{penFont=c}) pen
-- | The font metrics (read-only).
***************
*** 114,118 ****
--
fontMetrics :: Font -> Attr Canvas FontMetrics
! fontMetrics font
= readAttr "fontMetrics" $ \canvas -> Port.getFontMetrics font (hcanvas canvas)
--- 105,109 ----
--
fontMetrics :: Font -> Attr Canvas FontMetrics
! fontMetrics font
= readAttr "fontMetrics" $ \canvas -> Port.getFontMetrics font (hcanvas canvas)
***************
*** 128,314 ****
-- | The font metrics of the current drawing pencil (read-only).
! penfontMetrics :: Attr Canvas FontMetrics
! penfontMetrics
= readAttr "penfontMetrics" $ \canvas -> Port.getPenFontMetrics (hcanvas canvas)
-- | The character width in the current pen font on a canvas (read-only).
--
! -- > do em <- get canvas (penfontCharWidth 'm')
! penfontCharWidth ::Char -> Attr Canvas Int
! penfontCharWidth c
= readAttr "penfontCharWidth" $ \canvas -> Port.getPenFontCharWidth c (hcanvas canvas)
-- | The string width in the current pen font on a canvas (read-only).
! penfontStringWidth :: String -> Attr Canvas Int
! penfontStringWidth s
= readAttr "penfontStringWidth" $ \canvas -> Port.getPenFontStringWidth s (hcanvas canvas)
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: CanvasHandle -> BufferMode -> Color -> Color -> HatchStyle -> (Canvas -> IO ()) -> IO ()
! withCanvas handle bmode fgcolor bgcolor hatch f
! = do c <- createCanvas handle p
! Port.initCanvas p bmode handle
! f c
! Port.doneCanvas handle
! where
! p = Port.defaultPen{ Port.penColor = fgcolor
! , Port.penBackColor = bgcolor
! , Port.penHatchStyle = hatch }
!
! defaultCanvas :: CanvasHandle -> IO Canvas
! defaultCanvas handle
! = createCanvas handle (Port.defaultPen)
!
! createCanvas :: CanvasHandle -> Pen -> IO Canvas
! createCanvas handle p
! = do vpen <- newVar p
! return (Canvas handle vpen)
!
! {--------------------------------------------------------------------
! Helpers for drawing figures
! --------------------------------------------------------------------}
! newVarPen :: Canvas -> IO (Var Pen)
! newVarPen can
! = do p <- get can pen
! newVar p
!
! withVarPen :: Var Pen -> Canvas -> IO a -> IO a
! withVarPen vp can io
! = do p <- getVar vp
! with can [pen =: p] io
!
!
! attrPenColor :: Attr w Pen -> Attr w Color
! attrPenColor pen
! = mapAttr penColor (\p c -> p{ penColor = c }) pen
!
! attrPenBackColor :: Attr w Pen -> Attr w Color
! attrPenBackColor pen
! = mapAttr penBackColor (\p c -> p{ penBackColor = c }) pen
!
! attrPenThickness :: Attr w Pen -> Attr w Int
! attrPenThickness pen
! = mapAttr penSize (\p t -> p{ penSize = t }) pen
!
! attrPenFont :: Attr w Pen -> Attr w Font
! attrPenFont pen
! = mapAttr penFont (\p f -> p{ penFont = f }) pen
!
!
! {--------------------------------------------------------------------
! Write text
! --------------------------------------------------------------------}
! data Write = Write{ writeText :: Var String
! , writePen :: Var Pen
! }
!
! penWrite = varAttr writePen
!
! instance Colored Write where
! color = attrPenColor penWrite
!
! instance Literate Write where
! text = varAttr writeText
! font = attrPenFont penWrite
!
! write :: Point -> [Prop Write] -> Canvas -> IO ()
! write p props can
! = do vp <- newVarPen can
! vtxt <- newVar ""
! set (Write vtxt vp) props
! txt <- getVar vtxt
! withVarPen vp can (Port.drawString p txt (hcanvas can))
!
!
! {--------------------------------------------------------------------
! Figures
! --------------------------------------------------------------------}
! -- | A line.
! data Line = Line{ linePen:: Var Pen }
!
! penLine :: Attr Line Pen
! penLine = varAttr linePen
!
! instance Colored Line where
! color = attrPenColor penLine
!
! instance Drawn Line where
! thickness = attrPenThickness penLine
!
! -- | Draw a line.
! line :: Point -> Point -> [Prop Line] -> Canvas -> IO ()
! line p0 p1 props can
! = do vp <- newVarPen can
! set (Line vp) props
! withVarPen vp can (Port.drawLine p0 p1 (hcanvas can))
!
!
!
! -- | A rectangle.
! data Rectangle = Rectangle{ rectFrame :: Var Rect
! , rectPen :: Var Pen
! }
!
! penRect = varAttr rectPen
!
! instance Colored Rectangle where
! color = attrPenColor penRect
!
! instance Drawn Rectangle where
! thickness = attrPenThickness penRect
!
! instance Dimensions Rectangle where
! frame = varAttr rectFrame
! -- | Draw a rectangle.
! rectangle :: Rect -> [Prop Rectangle] -> Canvas -> IO ()
! rectangle r props can
! = do rectFrame <- newVar r
! rectPen <- newVarPen can
! set (Rectangle rectFrame rectPen) props
! frame <- getVar rectFrame
! withVarPen rectPen can (Port.drawRect frame (hcanvas can))
! -- | An ellipse
! data Ellipse = Ellipse{ ellipseFrame :: Var Rect
! , ellipsePen :: Var Pen
! }
! penEllipse = varAttr ellipsePen
! instance Colored Ellipse where
! color = attrPenColor penEllipse
! instance Drawn Ellipse where
! thickness = attrPenThickness penEllipse
! instance Dimensions Ellipse where
! frame = varAttr ellipseFrame
! -- | Draw an ellipse, given a center point and the x- and y radius.
! ellipse :: Point -> Int -> Int -> [Prop Ellipse] -> Canvas -> IO ()
! ellipse (Point x y) rx ry props can
! = do ellipseFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! ellipsePen <- newVarPen can
! set (Ellipse ellipseFrame ellipsePen) props
! frame <- getVar ellipseFrame
! withVarPen ellipsePen can (Port.drawOval frame (hcanvas can))
! circle :: Point -> Int -> [Prop Ellipse] -> Canvas -> IO ()
! circle p radius props canvas
! = ellipse p radius radius props canvas
! -- | An arc
! data Arc = Arc{ arcPen :: Var Pen
! }
! penArc = varAttr arcPen
! instance Colored Arc where
! color = attrPenColor penArc
! instance Drawn Arc where
! thickness = attrPenThickness penArc
-- | Draw an arc. The expression (arc c rx ry start end [] canvas) draws a curve on the oval
--- 119,199 ----
-- | The font metrics of the current drawing pencil (read-only).
! canvasFontMetrics :: Attr Canvas FontMetrics
! canvasFontMetrics
= readAttr "penfontMetrics" $ \canvas -> Port.getPenFontMetrics (hcanvas canvas)
-- | The character width in the current pen font on a canvas (read-only).
--
! -- > do em <- get canvas (canvasFontCharWidth 'm')
! canvasFontCharWidth ::Char -> Attr Canvas Int
! canvasFontCharWidth c
= readAttr "penfontCharWidth" $ \canvas -> Port.getPenFontCharWidth c (hcanvas canvas)
-- | The string width in the current pen font on a canvas (read-only).
! canvasFontStringWidth :: String -> Attr Canvas Int
! canvasFontStringWidth s
= readAttr "penfontStringWidth" $ \canvas -> Port.getPenFontStringWidth s (hcanvas canvas)
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: BufferMode -> Pen -> CanvasHandle -> (Canvas -> IO a) -> IO a
! withCanvas bmode pen handle f
! = do vpen <- newVar pen
! Port.withCanvas pen bmode handle (f (Canvas handle vpen))
! --------------------------------------------------------------------
! -- Drawing primitives
! --------------------------------------------------------------------
! -- | Draws the specified text string at the specified location.
! drawString :: Point -> String -> Canvas -> IO ()
! drawString p txt can = Port.drawString p txt (hcanvas can)
! -- | Draws a line connecting the two points specified by coordinate pairs.
! drawLine :: Point -> Point -> Canvas -> IO ()
! drawLine p0 p1 can = Port.drawLine p0 p1 (hcanvas can)
! -- | Draws a series of line segments that connect an list of points.
! drawPolyline :: [Point] -> Canvas -> IO ()
! drawPolyline points can = Port.drawPolyline points (hcanvas can)
! -- | Draws a rectangle specified by a Rect.
! drawRect :: Rect -> Canvas -> IO ()
! drawRect frame can = Port.drawRect frame (hcanvas can)
! -- | Fills the interior of a rectangle specified by a Rect.
! fillRect :: Rect -> Canvas -> IO ()
! fillRect frame can = Port.fillRect frame (hcanvas can)
! -- | Draws an ellipse specified by a bounding rectangle.
! drawOval :: Rect -> Canvas -> IO ()
! drawOval frame can = Port.drawOval frame (hcanvas can)
! -- | Draw an ellipse specified by a center point and the x- and y radius.
! drawEllipse :: Point -> Int -> Int -> Canvas -> IO ()
! drawEllipse (Point x y) rx ry can
! = Port.drawOval (Rect (x-rx) (y-ry) (x+rx) (y+ry)) (hcanvas can)
+ -- | Draw an circle specified by a center point and the radius.
+ drawCircle :: Point -> Int -> Canvas -> IO ()
+ drawCircle (Point x y) r can
+ = Port.drawOval (Rect (x-r) (y-r) (x+r) (y+r)) (hcanvas can)
! -- | Fills the interior of an ellipse defined by a bounding rectangle specified by a Rect.
! fillOval :: Rect -> Canvas -> IO ()
! fillOval frame can = Port.fillOval frame (hcanvas can)
! -- | Fills the interior of an ellipse specified by a center point and the x- and y radius.
! fillEllipse :: Point -> Int -> Int -> Canvas -> IO ()
! fillEllipse (Point x y) rx ry can = Port.fillOval (Rect (x-rx) (y-ry) (x+rx) (y+ry)) (hcanvas can)
! -- | Fills the interior of a circle specified by a center point and the radius.
! fillCircle :: Point -> Int -> Canvas -> IO ()
! fillCircle (Point x y) r can = Port.fillOval (Rect (x-r) (y-r) (x+r) (y+r)) (hcanvas can)
! -- | Draws an curve representing a portion of an ellipse specified by a Rect. The Float type
! -- arguments specifies @start@ and @end@ angles in radians. The curve starts at an angle @start@
! -- continuing in clockwise direction to the ending angle @end@.
! drawCurve :: Rect -> Float -> Float -> Canvas -> IO ()
! drawCurve frame start end can = Port.drawCurve frame start end (hcanvas can)
-- | Draw an arc. The expression (arc c rx ry start end [] canvas) draws a curve on the oval
***************
*** 316,461 ****
-- at an angle @start@ (in radians) continuing in clockwise direction
-- to the ending angle @end@ (in radians).
! arc :: Point -> Int -> Int -> Float -> Float -> [Prop Arc] -> Canvas -> IO ()
! arc (Point x y) rx ry start end props can
! = do arcPen <- newVarPen can
! set (Arc arcPen) props
! withVarPen arcPen can (Port.drawCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can))
!
!
!
! -- | An poly line.
! data Polyline = Polyline{ polyPen :: Var Pen}
!
! penPolyline = varAttr polyPen
!
! instance Colored Polyline where
! color = attrPenColor penPolyline
!
! instance Drawn Polyline where
! thickness = attrPenThickness penPolyline
!
! -- | Draw a poly line.
! polyline :: [Point] -> [Prop Polyline] -> Canvas -> IO ()
! polyline points props can
! = do polyPen <- newVarPen can
! set (Polyline polyPen) props
! withVarPen polyPen can (Port.drawPolyline points (hcanvas can))
!
!
!
! {--------------------------------------------------------------------
! Solids
! --------------------------------------------------------------------}
! -- | A box.
! data Box = Box{ boxFrame :: Var Rect
! , boxPen :: Var Pen
! }
!
! penBox = varAttr boxPen
!
! instance Colored Box where
! color = attrPenColor penBox
!
! instance Dimensions Box where
! frame = varAttr boxFrame
!
! -- | Draw a box.
! box :: Rect -> [Prop Box] -> Canvas -> IO ()
! box r props can
! = do boxFrame <- newVar r
! boxPen <- newVarPen can
! set (Box boxFrame boxPen) props
! frame <- getVar boxFrame
! withVarPen boxPen can (Port.fillRect frame (hcanvas can))
!
! -- | An oval
! data Oval = Oval{ ovalFrame :: Var Rect
! , ovalPen :: Var Pen
! }
!
! penOval = varAttr ovalPen
!
! instance Colored Oval where
! color = attrPenColor penOval
!
! instance Dimensions Oval where
! frame = varAttr ovalFrame
!
! -- | Draw an oval.
! oval :: Point -> Int -> Int -> [Prop Oval] -> Canvas -> IO ()
! oval (Point x y) rx ry props can
! = do ovalFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! ovalPen <- newVarPen can
! set (Oval ovalFrame ovalPen) props
! frame <- getVar ovalFrame
! withVarPen ovalPen can (Port.fillOval frame (hcanvas can))
!
!
! disc :: Point -> Int -> [Prop Oval] -> Canvas -> IO ()
! disc p radius props canvas
! = oval p radius radius props canvas
!
!
!
! -- | A pie
! data Pie = Pie{ pieFrame :: Var Rect
! , piePen :: Var Pen
! }
!
! penPie = varAttr piePen
!
! instance Colored Pie where
! color = attrPenColor penPie
!
! instance Dimensions Pie where
! frame = varAttr pieFrame
!
! -- | Draw a pie.
! pie :: Point -> Int -> Int -> Float -> Float -> [Prop Pie] -> Canvas -> IO ()
! pie (Point x y) rx ry start end props can
! = do pieFrame <- newVar (Rect (x-rx) (y-ry) (x+rx) (y+ry))
! piePen <- newVarPen can
! set (Pie pieFrame piePen) props
! frame <- getVar pieFrame
! withVarPen piePen can (Port.fillCurve frame start end (hcanvas can))
!
!
!
! -- | A polygon
! data Polygon = Polygon{ polygonPen :: Var Pen}
!
! penPolygon = varAttr polygonPen
!
! instance Colored Polygon where
! color = attrPenColor penPolygon
!
! -- | Draw a polygon.
! polygon :: [Point] -> [Prop Polygon] -> Canvas -> IO ()
! polygon points props can
! = do polygonPen <- newVarPen can
! set (Polygon polygonPen) props
! withVarPen polygonPen can (Port.fillPolygon points (hcanvas can))
!
!
!
!
! -- | Draw a bitmap
! bitmap :: Point -> Bitmap -> Canvas -> IO ()
! bitmap p bitmap can = Port.drawBitmap p bitmap (hcanvas can)
! {--------------------------------------------------------------------
! figures:
! line
! polyline
! rectangle
! ellipse
! circle
! arc
! solids
! polygon
! box
! oval
! disc
! pie
! --------------------------------------------------------------------}
--- 201,218 ----
-- at an angle @start@ (in radians) continuing in clockwise direction
-- to the ending angle @end@ (in radians).
! drawArc :: Point -> Int -> Int -> Float -> Float -> Canvas -> IO ()
! drawArc (Point x y) rx ry start end can
! = Port.drawCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can)
!
! -- | Fills the interior of a pie section defined by an ellipse specified by a by a center point and the x- and y radius
! -- and two radial lines at angles @start@ and @end@. The Float arguments specifies the angles.
! fillPie :: Point -> Int -> Int -> Float -> Float -> Canvas -> IO ()
! fillPie (Point x y) rx ry start end can = Port.fillCurve (Rect (x-rx) (y-ry) (x+rx) (y+ry)) start end (hcanvas can)
! -- | Draws a polygon defined by an list of points
! drawPolygon :: [Point] -> Canvas -> IO ()
! drawPolygon points can = Port.fillPolygon points (hcanvas can)
! -- | Draws the specified Bitmap at the specified location.
! drawBitmap :: Point -> Bitmap -> Canvas -> IO ()
! drawBitmap p bitmap can = Port.drawBitmap p bitmap (hcanvas can)
Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Controls.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Controls.hs 26 Apr 2003 20:54:00 -0000 1.10
--- Controls.hs 30 May 2003 11:39:08 -0000 1.11
***************
*** 51,56 ****
return lab
! instance Literate Label where
! text = newAttr (Port.getLabelText . lhandle) (Port.setLabelText . lhandle)
font = newAttr (getVar . lfont) (\w font -> Port.changeLabelFont (lhandle w) font >> setVar (lfont w) font)
--- 51,58 ----
return lab
! instance Titled Label where
! title = newAttr (Port.getLabelText . lhandle) (Port.setLabelText . lhandle)
!
! instance HasFont Label where
font = newAttr (getVar . lfont) (\w font -> Port.changeLabelFont (lhandle w) font >> setVar (lfont w) font)
***************
*** 87,93 ****
return but
! instance Literate Button where
! text = newAttr (\b -> Port.getButtonText (bhandle b))
! (\b txt -> Port.setButtonText (bhandle b) txt)
font = newAttr (getVar . bfont) (\w font -> Port.changeButtonFont (bhandle w) font >> setVar (bfont w) font)
--- 89,96 ----
return but
! instance Titled Button where
! title = newAttr (Port.getButtonText . bhandle) (Port.setButtonText . bhandle)
!
! instance HasFont Button where
font = newAttr (getVar . bfont) (\w font -> Port.changeButtonFont (bhandle w) font >> setVar (bfont w) font)
***************
*** 128,133 ****
return e
! instance Literate Entry where
! text = newAttr (Port.getEditText . ehandle) (Port.setEditText . ehandle)
font = newAttr (getVar . efont) (\w font -> Port.changeEditBoxFont (ehandle w) font >> setVar (efont w) font)
--- 131,138 ----
return e
! instance Titled Entry where
! title = newAttr (Port.getEditText . ehandle) (Port.setEditText . ehandle)
!
! instance HasFont Entry where
font = newAttr (getVar . efont) (\w font -> Port.changeEditBoxFont (ehandle w) font >> setVar (efont w) font)
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Types.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Types.hs 13 Apr 2003 19:12:07 -0000 1.9
--- Types.hs 30 May 2003 11:39:08 -0000 1.10
***************
*** 77,80 ****
--- 77,81 ----
, LineStyle(..)
, HatchStyle(..)
+ , Pen(..), defaultPen, dialogPen
-- ** Fonts
***************
*** 106,109 ****
--- 107,111 ----
import Graphics.UI.Port.Types
import Graphics.UI.Port.Colors
+ import Graphics.UI.Port.Canvas(Pen(..), defaultPen, dialogPen)
import Control.Concurrent.MVar
{--------------------------------------------------------------------
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** Window.hs 30 May 2003 08:23:09 -0000 1.15
--- Window.hs 30 May 2003 11:39:09 -0000 1.16
***************
*** 34,43 ****
, vresizeable :: Var Bool
, vautosize :: Var Bool
! , vcolor :: Var Color
! , vbgcolor :: Var Color
! , vhatch :: Var HatchStyle
! , vpaint :: Var PaintFunction
! , vlayout :: Var Layout
, vbufferMode :: Var BufferMode
}
--- 34,41 ----
, vresizeable :: Var Bool
, vautosize :: Var Bool
! , vpen :: Var Pen
, vbufferMode :: Var BufferMode
+ , vpaint :: Var PaintFunction
+ , vlayout :: Var Layout
}
***************
*** 45,49 ****
window :: [Prop Window] -> IO Window
window props
! = do w <- Lib.createWindow >>= form
set w [bgcolor =: white]
set w props
--- 43,47 ----
window :: [Prop Window] -> IO Window
window props
! = do w <- Lib.createWindow >>= form defaultPen
set w [bgcolor =: white]
set w props
***************
*** 61,65 ****
dialog props mb_parent
= do let hparent = maybe Lib.nullHandle hwindow mb_parent
! w <- Lib.createDialog hparent >>= form
set w props
Lib.showWindow (hwindow w)
--- 59,63 ----
dialog props mb_parent
= do let hparent = maybe Lib.nullHandle hwindow mb_parent
! w <- Lib.createDialog hparent >>= form dialogPen
set w props
Lib.showWindow (hwindow w)
***************
*** 70,75 ****
runDialog w = Lib.runDialog (hwindow w)
! form :: WindowHandle -> IO Window
! form hwindow
= do w <- do vpaint <- newVar (\_ _ _ -> return ())
vautosize <- newVar True
--- 68,73 ----
runDialog w = Lib.runDialog (hwindow w)
! form :: Pen -> WindowHandle -> IO Window
! form pen hwindow
= do w <- do vpaint <- newVar (\_ _ _ -> return ())
vautosize <- newVar True
***************
*** 77,87 ****
vdomain <- newVar (sz 0 0)
vresizeable<- newVar True
! vcolor <- newVar black
! vbgcolor <- newVar dialoggray
! vhatch <- newVar HatchSolid
vbufferMode<- newVar UnBuffered
return (Window hwindow vdomain vresizeable vautosize
! vcolor vbgcolor vhatch
! vpaint vlayout vbufferMode
)
recolorWindow w
--- 75,82 ----
vdomain <- newVar (sz 0 0)
vresizeable<- newVar True
! vpen <- newVar pen
vbufferMode<- newVar UnBuffered
return (Window hwindow vdomain vresizeable vautosize
! vpen vbufferMode vpaint vlayout
)
recolorWindow w
***************
*** 161,176 ****
(\w r -> Lib.setWindowFrame (hwindow w) r)
!
! instance Colored Window where
! color = newAttr (\w -> getVar (vcolor w))
! (\w c -> do setVar (vcolor w) c; recolorWindow w)
!
! instance Background Window where
! bgcolor = newAttr (\w -> getVar (vbgcolor w))
! (\w c -> do setVar (vbgcolor w) c; recolorWindow w)
!
! instance Filled Window where
! hatch = newAttr (\w -> getVar (vhatch w))
! (\w h -> do setVar (vhatch w) h; recolorWindow w)
instance Reactive Window where
--- 156,164 ----
(\w r -> Lib.setWindowFrame (hwindow w) r)
! instance Drawn Window where
! pen = newAttr (getVar . vpen) (\w pen -> setVar (vpen w) pen >> recolorWindow w)
!
! instance HasFont Window where
! font = mapAttr penFont (\pen c -> pen{penFont=c}) pen
instance Reactive Window where
***************
*** 190,198 ****
where
wndpaint w paintfun hcanvas updArea
! = do col <- get w color
! bgcol <- get w bgcolor
! hat <- get w hatch
bmode <- get w bufferMode
! withCanvas hcanvas bmode col bgcol hat $ \can -> paintfun can updArea []
instance Able Window where
--- 178,184 ----
where
wndpaint w paintfun hcanvas updArea
! = do pen <- get w pen
bmode <- get w bufferMode
! withCanvas bmode pen hcanvas $ \can -> paintfun can updArea []
instance Able Window where
|
|
From: <kr_...@us...> - 2003-05-30 08:44:06
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv31982/src/Graphics/UI/GIO
Modified Files:
Canvas.hs Window.hs
Log Message:
Enable adjustment of BufferedMode for GIO Window
Index: Canvas.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Canvas.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** Canvas.hs 12 Apr 2003 07:30:58 -0000 1.7
--- Canvas.hs 30 May 2003 08:23:08 -0000 1.8
***************
*** 145,152 ****
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: CanvasHandle -> Color -> Color -> HatchStyle -> (Canvas -> IO ()) -> IO ()
! withCanvas handle fgcolor bgcolor hatch f
= do c <- createCanvas handle p
! Port.initCanvas p Port.Buffered handle
f c
Port.doneCanvas handle
--- 145,152 ----
-- Paint on a primitive canvas. Just for internal use.
! withCanvas :: CanvasHandle -> BufferMode -> Color -> Color -> HatchStyle -> (Canvas -> IO ()) -> IO ()
! withCanvas handle bmode fgcolor bgcolor hatch f
= do c <- createCanvas handle p
! Port.initCanvas p bmode handle
f c
Port.doneCanvas handle
Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Window.hs,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Window.hs 26 Apr 2003 20:54:00 -0000 1.14
--- Window.hs 30 May 2003 08:23:09 -0000 1.15
***************
*** 12,16 ****
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize
, dialog, runDialog
-- * Internal
--- 12,16 ----
-----------------------------------------------------------------------------------------
module Graphics.UI.GIO.Window
! ( Window, window, domain, resizeable, view, layout, autosize, bufferMode
, dialog, runDialog
-- * Internal
***************
*** 39,42 ****
--- 39,43 ----
, vpaint :: Var PaintFunction
, vlayout :: Var Layout
+ , vbufferMode :: Var BufferMode
}
***************
*** 71,85 ****
form :: WindowHandle -> IO Window
form hwindow
! = do w <- do vpaint <- newVar (\_ _ _ -> return ())
! vautosize <- newVar True
! vlayout <- newVar empty
! vdomain <- newVar (sz 0 0)
! vresizeable <- newVar True
! vcolor <- newVar black
! vbgcolor <- newVar dialoggray
! vhatch <- newVar HatchSolid
return (Window hwindow vdomain vresizeable vautosize
vcolor vbgcolor vhatch
! vpaint vlayout
)
recolorWindow w
--- 72,87 ----
form :: WindowHandle -> IO Window
form hwindow
! = do w <- do vpaint <- newVar (\_ _ _ -> return ())
! vautosize <- newVar True
! vlayout <- newVar empty
! vdomain <- newVar (sz 0 0)
! vresizeable<- newVar True
! vcolor <- newVar black
! vbgcolor <- newVar dialoggray
! vhatch <- newVar HatchSolid
! vbufferMode<- newVar UnBuffered
return (Window hwindow vdomain vresizeable vautosize
vcolor vbgcolor vhatch
! vpaint vlayout vbufferMode
)
recolorWindow w
***************
*** 141,144 ****
--- 143,152 ----
(\w sz-> Lib.setWindowViewSize (hwindow w) sz)
+ -- | The buffering mode for Window. If the window is buffered then all
+ -- drawing operations are first performed to memory buffer and after
+ -- that the buffer is copied to the screen.
+ bufferMode :: Attr Window BufferMode
+ bufferMode = newAttr (getVar . vbufferMode) (setVar . vbufferMode)
+
instance Dismissible Window where
dismissWidget w = Lib.dismissWindow (hwindow w)
***************
*** 185,189 ****
bgcol <- get w bgcolor
hat <- get w hatch
! withCanvas hcanvas col bgcol hat $ \can -> paintfun can updArea []
instance Able Window where
--- 193,198 ----
bgcol <- get w bgcolor
hat <- get w hatch
! bmode <- get w bufferMode
! withCanvas hcanvas bmode col bgcol hat $ \can -> paintfun can updArea []
instance Able Window where
|
|
From: <kr_...@us...> - 2003-05-03 09:15:11
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32 In directory sc8-pr-cvs1:/tmp/cvs-serv21067/src/cbits/Win32 Modified Files: Frame.c Log Message: bugfix Index: Frame.c =================================================================== RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Frame.c,v retrieving revision 1.9 retrieving revision 1.10 diff -C2 -d -r1.9 -r1.10 *** Frame.c 1 May 2003 20:38:26 -0000 1.9 --- Frame.c 3 May 2003 09:15:08 -0000 1.10 *************** *** 83,87 **** return -1; } ! GetWindowText(hWnd,pData->lpszAppName,nLen); } --- 83,87 ---- return -1; } ! GetWindowText(hWnd,pData->lpszAppName,nLen+1); } |
|
From: <kr_...@us...> - 2003-05-02 06:41:36
|
Update of /cvsroot/htoolkit/port/src/cbits/GTK
In directory sc8-pr-cvs1:/tmp/cvs-serv12460
Added Files:
AboutDialog.c
Log Message:
added AboutDialog (still for Linux only)
--- NEW FILE: AboutDialog.c ---
#include "CommonDialogs.h"
#include "Internals.h"
gchar **strList2Array(char *list)
{
int count, i;
gchar *s, **array;
if (!list) return NULL;
count = 0;
for (s = list; *s; s+=strlen(s)+1) count++;
array = (char**) malloc((count+1)*sizeof(gchar*));
if (!array)
return NULL;
i = 0;
for (s = list; *s; s+=strlen(s)+1) array[i++] = s;
array[i] = NULL;
return array;
}
void osRunAboutDialog(char *appName, char *appVersion, char *copyright, char *comments, char *authors, char *documenters, char *translator_credits, BitmapHandle bitmap, WindowHandle owner)
{
gchar **authorsArr, **documentersArr;
authorsArr = strList2Array(authors);
documentersArr = strList2Array(documenters);
GtkWidget *about = gnome_about_new(appName,
appVersion,
copyright,
comments,
authorsArr ? authorsArr : &authorsArr,
documentersArr,
translator_credits,
bitmap->pixbuf);
if (owner)
owner = gtk_widget_get_toplevel(owner);
else
owner = gFrameWidget;
gtk_window_set_transient_for(GTK_WINDOW(about), GTK_WINDOW(owner));
gtk_dialog_run(GTK_DIALOG(about));
free(documentersArr);
free(authorsArr);
}
|
|
From: <kr_...@us...> - 2003-05-02 06:35:34
|
Update of /cvsroot/htoolkit/port/src/include In directory sc8-pr-cvs1:/tmp/cvs-serv9023/port/src/include Modified Files: CommonDialogs.h Log Message: added AboutDialog (still only Linux) Index: CommonDialogs.h =================================================================== RCS file: /cvsroot/htoolkit/port/src/include/CommonDialogs.h,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** CommonDialogs.h 26 Apr 2003 21:02:15 -0000 1.1 --- CommonDialogs.h 2 May 2003 06:35:30 -0000 1.2 *************** *** 13,15 **** --- 13,17 ---- BOOL osRunFontDialog(char **fname, int *fsize, int *fweight, int *fstyle, BOOL *funderline, BOOL *fstrikeout, WindowHandle owner); + void osRunAboutDialog(char *appName, char *appVersion, char *copyright, char *comments, char *authors, char *documenters, char *translator_credits, BitmapHandle bitmap, WindowHandle owner); + #endif |
|
From: <kr_...@us...> - 2003-05-02 06:35:34
|
Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv9023/port/src/Port
Modified Files:
CommonDialogs.hs Types.hs
Log Message:
added AboutDialog (still only Linux)
Index: CommonDialogs.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/CommonDialogs.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** CommonDialogs.hs 26 Apr 2003 21:02:13 -0000 1.3
--- CommonDialogs.hs 2 May 2003 06:35:30 -0000 1.4
***************
*** 19,22 ****
--- 19,23 ----
, runColorDialog
, runFontDialog
+ , runAboutDialog
) where
***************
*** 126,132 ****
alloca $ \fstrikeoutref -> do
res <- osRunFontDialog fnameref fsizeref fweightref fstyleref funderlineref fstrikeoutref owner
! if res
then do
! cname <- peek fnameref
csize <- peek fsizeref
cweight <- peek fweightref
--- 127,133 ----
alloca $ \fstrikeoutref -> do
res <- osRunFontDialog fnameref fsizeref fweightref fstyleref funderlineref fstrikeoutref owner
! if res
then do
! cname <- peek fnameref
csize <- peek fsizeref
cweight <- peek fweightref
***************
*** 140,141 ****
--- 141,167 ----
foreign import ccall osRunFontDialog :: Ptr CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CBool -> Ptr CBool -> WindowHandle -> IO Bool
+ -----------------------------------------------------------------------------------------
+ -- About dialog
+ -----------------------------------------------------------------------------------------
+
+ runAboutDialog :: String -- ^ application name
+ -> String -- ^ application version
+ -> String -- ^ copyright
+ -> String -- ^ comments
+ -> [String] -- ^ authors
+ -> [String] -- ^ documenters
+ -> String -- ^ translator credits
+ -> Bitmap -- ^ logo
+ -> WindowHandle
+ -> IO ()
+ runAboutDialog appName appVersion copyright comments authors documenters tcredits logo owner =
+ withCString appName $ \cAppName ->
+ withCString appVersion $ \cAppVersion ->
+ withCString copyright $ \cCopyright ->
+ withCString comments $ \cComments ->
+ withCStrings authors $ \cAuthors ->
+ withCStrings documenters $ \cDocumenters ->
+ (if null tcredits then ($ nullPtr) else withCString tcredits) $ \cTCredits ->
+ withCBitmap logo $ \cBmp ->
+ osRunAboutDialog cAppName cAppVersion cCopyright cComments cAuthors cDocumenters cTCredits cBmp owner
+ foreign import ccall osRunAboutDialog :: CString -> CString -> CString -> CString -> Ptr CChar -> Ptr CChar -> CString -> BitmapHandle -> WindowHandle -> IO ()
Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -d -r1.17 -r1.18
*** Types.hs 31 Mar 2003 00:12:06 -0000 1.17
--- Types.hs 2 May 2003 06:35:30 -0000 1.18
***************
*** 110,114 ****
, CBool, fromCBool, toCBool
, fromCChar, toCChar
! , peekCStrings, resultCString, resultCStrings
) where
--- 110,114 ----
, CBool, fromCBool, toCBool
, fromCChar, toCChar
! , withCStrings, peekCStrings, resultCString, resultCStrings
) where
***************
*** 1053,1060 ****
= toEnum (fromIntegral cc)
! peekCStrings :: CString -> IO [String]
peekCStrings cstrs
| cstrs == nullPtr = return []
! | otherwise = do
str <- peekCString cstrs
if (null str)
--- 1053,1073 ----
= toEnum (fromIntegral cc)
! withCStrings :: [String] -> (Ptr CChar -> IO a) -> IO a
! withCStrings [] io = io nullPtr
! withCStrings strings io = allocaArray (memSize strings) $ \cbuffer -> do
! pokeStrings strings cbuffer
! io cbuffer
! where
! memSize = foldr (\x xs -> xs + length x + 1) 1
!
! pokeStrings [] cbuffer = poke cbuffer (castCharToCChar '\0')
! pokeStrings (s:ss) cbuffer = do
! pokeArray0 (castCharToCChar '\0') cbuffer (map castCharToCChar s)
! pokeStrings ss (cbuffer `plusPtr` (length s+1))
!
! peekCStrings :: Ptr CChar -> IO [String]
peekCStrings cstrs
| cstrs == nullPtr = return []
! | otherwise = do
str <- peekCString cstrs
if (null str)
***************
*** 1072,1076 ****
-- | Convert and free a c-string of c-strings.
! resultCStrings :: IO CString -> IO [String]
resultCStrings io
! = bracket io free peekCStrings
\ No newline at end of file
--- 1085,1089 ----
-- | Convert and free a c-string of c-strings.
! resultCStrings :: IO (Ptr CChar) -> IO [String]
resultCStrings io
! = bracket io free peekCStrings
|
|
From: <kr_...@us...> - 2003-05-02 06:35:33
|
Update of /cvsroot/htoolkit/port In directory sc8-pr-cvs1:/tmp/cvs-serv9023/port Modified Files: makefile Log Message: added AboutDialog (still only Linux) Index: makefile =================================================================== RCS file: /cvsroot/htoolkit/port/makefile,v retrieving revision 1.19 retrieving revision 1.20 diff -C2 -d -r1.19 -r1.20 *** makefile 26 Apr 2003 20:56:33 -0000 1.19 --- makefile 2 May 2003 06:35:30 -0000 1.20 *************** *** 48,52 **** CSRCS = Window.c Util.c Bitmap.c Button.c CheckBox.c EditBox.c \ ! FileDialog.c ColorDialog.c FontDialog.c PopUp.c Canvas.c Menu.c ListBox.c \ Label.c Font.c RadioBox.c Timer.c Frame.c Message.c Slider.c ProgressBar.c --- 48,52 ---- CSRCS = Window.c Util.c Bitmap.c Button.c CheckBox.c EditBox.c \ ! FileDialog.c ColorDialog.c FontDialog.c AboutDialog.c PopUp.c Canvas.c Menu.c ListBox.c \ Label.c Font.c RadioBox.c Timer.c Frame.c Message.c Slider.c ProgressBar.c |
|
From: <kr_...@us...> - 2003-05-02 06:35:33
|
Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv9023/gio/src/Graphics/UI/GIO
Modified Files:
CommonDialogs.hs
Log Message:
added AboutDialog (still only Linux)
Index: CommonDialogs.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/CommonDialogs.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** CommonDialogs.hs 26 Apr 2003 20:56:34 -0000 1.3
--- CommonDialogs.hs 2 May 2003 06:35:30 -0000 1.4
***************
*** 18,21 ****
--- 18,22 ----
, runFontDialog
, runColorDialog
+ , runAboutDialog
) where
***************
*** 37,41 ****
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected file
! runInputFileDialog title filter mb_parent = Lib.runInputFileDialog title filter (getWHandle mb_parent)
-- | Run a dialog to select an input file. Returns 'Nothing' when cancelled.
--- 38,42 ----
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected file
! runInputFileDialog title filter mb_owner = Lib.runInputFileDialog title filter (getWHandle mb_owner)
-- | Run a dialog to select an input file. Returns 'Nothing' when cancelled.
***************
*** 47,51 ****
-> Maybe Window -- ^ The owner window
-> IO [FilePath] -- ^ The list of full qualified paths for the selected files
! runInputFilesDialog title filter mb_parent = Lib.runInputFilesDialog title filter (getWHandle mb_parent)
-- | Run a dialog to select an output file. Returns 'Nothing' when cancelled.
--- 48,52 ----
-> Maybe Window -- ^ The owner window
-> IO [FilePath] -- ^ The list of full qualified paths for the selected files
! runInputFilesDialog title filter mb_owner = Lib.runInputFilesDialog title filter (getWHandle mb_owner)
-- | Run a dialog to select an output file. Returns 'Nothing' when cancelled.
***************
*** 58,62 ****
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected file
! runOutputFileDialog title filter fname mb_parent = Lib.runOutputFileDialog title filter fname (getWHandle mb_parent)
-- | Runs a dialog to select a directory. Returns 'Nothing' when cancelled.
--- 59,63 ----
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected file
! runOutputFileDialog title filter fname mb_owner = Lib.runOutputFileDialog title filter fname (getWHandle mb_owner)
-- | Runs a dialog to select a directory. Returns 'Nothing' when cancelled.
***************
*** 64,79 ****
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected directory
! runDirectoryDialog title mb_parent = Lib.runDirectoryDialog title (getWHandle mb_parent)
-- | Run a dialog to select a font. Returns 'Nothing' when cancelled.
runFontDialog :: Maybe Window -- ^ The owner window
-> IO (Maybe FontDef)
! runFontDialog mb_parent = Lib.runFontDialog (getWHandle mb_parent)
-- | Run a dialog to select a color. Returns 'Nothing' when cancelled.
runColorDialog :: Maybe Window -- ^ The owner window
-> IO (Maybe Color)
! runColorDialog mb_parent = Lib.runColorDialog (getWHandle mb_parent)
getWHandle = maybe Lib.nullHandle hwindow
--- 65,92 ----
-> Maybe Window -- ^ The owner window
-> IO (Maybe FilePath) -- ^ The full qualified path to the selected directory
! runDirectoryDialog title mb_owner = Lib.runDirectoryDialog title (getWHandle mb_owner)
-- | Run a dialog to select a font. Returns 'Nothing' when cancelled.
runFontDialog :: Maybe Window -- ^ The owner window
-> IO (Maybe FontDef)
! runFontDialog mb_owner = Lib.runFontDialog (getWHandle mb_owner)
-- | Run a dialog to select a color. Returns 'Nothing' when cancelled.
runColorDialog :: Maybe Window -- ^ The owner window
-> IO (Maybe Color)
! runColorDialog mb_owner = Lib.runColorDialog (getWHandle mb_owner)
+ runAboutDialog :: String -- ^ application name
+ -> String -- ^ application version
+ -> String -- ^ copyright
+ -> String -- ^ comments
+ -> [String] -- ^ authors
+ -> [String] -- ^ documenters
+ -> String -- ^ translator credits
+ -> Bitmap -- ^ logo
+ -> Maybe Window -- ^ The owner window
+ -> IO ()
+ runAboutDialog appName appVersion copyright comments authors documenters tcredits logo mb_owner =
+ Lib.runAboutDialog appName appVersion copyright comments authors documenters tcredits logo (getWHandle mb_owner)
getWHandle = maybe Lib.nullHandle hwindow
|
|
From: <kr_...@us...> - 2003-05-01 20:45:37
|
Update of /cvsroot/htoolkit/port/src/cbits/GTK In directory sc8-pr-cvs1:/tmp/cvs-serv10544/src/cbits/GTK Modified Files: Util.c Log Message: Free gAppName and gAppVersion strings after the handleProcessDestroy event Index: Util.c =================================================================== RCS file: /cvsroot/htoolkit/port/src/cbits/GTK/Util.c,v retrieving revision 1.16 retrieving revision 1.17 diff -C2 -d -r1.16 -r1.17 *** Util.c 1 May 2003 19:35:36 -0000 1.16 --- Util.c 1 May 2003 20:45:32 -0000 1.17 *************** *** 57,60 **** --- 57,62 ---- gtk_main(); handleProcessDestroy(); + free(gAppName); + free(gAppVersion); } |
|
From: <kr_...@us...> - 2003-05-01 20:38:31
|
Update of /cvsroot/htoolkit/port/src/cbits/Win32
In directory sc8-pr-cvs1:/tmp/cvs-serv7327/port/src/cbits/Win32
Modified Files:
Frame.c Internals.h Util.c
Log Message:
Make the Win32 port compatible with new GTK/GNOME port
Index: Frame.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Frame.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** Frame.c 25 Apr 2003 21:15:31 -0000 1.8
--- Frame.c 1 May 2003 20:38:26 -0000 1.9
***************
*** 28,31 ****
--- 28,32 ----
DeleteObject(pData->hControlFont);
free(pData->lpszAppName);
+ free(pData->lpszAppVersion);
deleteMenuHandlesMap(pData->pMenuHandlesMap);
free(pData);
***************
*** 69,72 ****
--- 70,74 ----
pData->hControlFont = hControlFont;
pData->lpszAppName = NULL;
+ pData->lpszAppVersion = NULL;
pData->pMenuHandlesMap = newMenuHandlesMap();
***************
*** 454,508 ****
return result;
};
-
- char *osGetProcessTitle()
- {
- FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
- return pFrameData->lpszAppName;
- }
-
- void osSetProcessTitle(char *szAppName)
- {
- HWND hWnd;
- char *s, *title;
- int nTextLen;
- FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
-
- pFrameData->lpszAppName = strdup(szAppName);
-
- hWnd = pFrameData->hClientWnd;
- if (pFrameData->DocumentInterface == 2)
- hWnd = (HWND) SendMessage(hWnd, WM_MDIGETACTIVE, 0, 0);
-
- s = NULL;
- if (hWnd)
- {
- nTextLen = GetWindowTextLength(hWnd);
- s = malloc(nTextLen+1);
- if (s) GetWindowText(hWnd, s, nTextLen);
- }
-
- if (pFrameData->lpszAppName && *pFrameData->lpszAppName)
- {
- if (s && *s)
- {
- title = malloc(strlen(pFrameData->lpszAppName)+nTextLen+6);
-
- if (title)
- {
- strcpy(title, pFrameData->lpszAppName);
- strcat(title, " - [");
- strcat(title, s);
- strcat(title, "]");
- SetWindowText(ghWndFrame, title);
- }
-
- rfree(title);
- }
- else
- SetWindowText(ghWndFrame, pFrameData->lpszAppName);
- }
- else
- SetWindowText(ghWndFrame, s ? s : "");
-
- free(s);
- }
--- 456,457 ----
Index: Internals.h
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Internals.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Internals.h 23 Apr 2003 21:58:12 -0000 1.1
--- Internals.h 1 May 2003 20:38:26 -0000 1.2
***************
*** 28,31 ****
--- 28,32 ----
HFONT hControlFont;
LPSTR lpszAppName;
+ LPSTR lpszAppVersion;
MenuHandlesMap *pMenuHandlesMap;
} FrameData;
Index: Util.c
===================================================================
RCS file: /cvsroot/htoolkit/port/src/cbits/Win32/Util.c,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Util.c 23 Apr 2003 21:48:54 -0000 1.12
--- Util.c 1 May 2003 20:38:26 -0000 1.13
***************
*** 50,54 ****
*/
! void osInit(int DocumentInterface)
{
if (!ghModule)
--- 50,54 ----
*/
! void osInit(char *appName, char *appVersion, int DocumentInterface)
{
if (!ghModule)
***************
*** 130,134 ****
{
ghWndFrame = CreateWindow ( "HSDIFRAME",
! NULL,
WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT,CW_USEDEFAULT,
--- 130,134 ----
{
ghWndFrame = CreateWindow ( "HSDIFRAME",
! appName,
WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT,CW_USEDEFAULT,
***************
*** 143,147 ****
{
ghWndFrame = CreateWindow ( "HMDIFRAME",
! NULL,
WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT,CW_USEDEFAULT,
--- 143,147 ----
{
ghWndFrame = CreateWindow ( "HMDIFRAME",
! appName,
WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT,CW_USEDEFAULT,
***************
*** 152,155 ****
--- 152,160 ----
NULL
);
+ }
+
+ { // Store appVersion for future usage
+ FrameData *pFrameData = (FrameData *) GetWindowLong(ghWndFrame,GWL_USERDATA);
+ pFrameData->lpszAppVersion = strdup(appVersion);
}
|
221 messages has been excluded from this view by a project administrator.
