packages feed

htzaar 0.0.1 → 0.0.2

raw patch · 7 files changed

+669/−2 lines, 7 files

Files

RELEASE-NOTES view
@@ -1,3 +1,9 @@+htzaar 0.0.2    10/09/09++- Added other modules to htzaar.cabal.+- Added strategy helpers to AI.Utils (boardHeuristic, pruneBoardTree).++ htzaar 0.0.1    10/07/09  - Fixed first turn caveat.
htzaar.cabal view
@@ -1,5 +1,5 @@ name:    htzaar-version: 0.0.1+version: 0.0.2  category: Game @@ -27,7 +27,11 @@ executable htzaar   hs-source-dirs:   src   main-is:          Main.hs-  other-modules:+  other-modules:    AI,+                    AI.Lame,+                    AI.Utils,+                    Board,+                    Play   build-depends:     base       >= 4       && < 5,     OpenGL     >= 2.4     && < 2.5,
+ src/AI.hs view
@@ -0,0 +1,10 @@+-- | Library of AI Players+module AI (ai) where++import Board++import AI.Lame++ai :: [AI]+ai = [lame]+
+ src/AI/Lame.hs view
@@ -0,0 +1,24 @@+-- | An example AI player.+module AI.Lame (lame) where++import System.Random++import AI.Utils+import Board++lame :: AI+lame = AI+  { name = "lame"+  , description = "Randomly selects the next valid turn."+  , strategy = winNext lameStrategy+  }++-- | The lame strategy picks a valid turn at random.  If a two-move turn is available, it picks one.  (wow, pretty smart!)+lameStrategy :: Strategy+lameStrategy (BoardTree _ _ branches) g = (turns !! i, g')+  where+  allTurns = fst $ unzip branches+  goodTurns = [ (m1, Just m2) | (m1, Just m2) <- allTurns ]+  turns = if null goodTurns then allTurns else goodTurns+  (i, g') = randomR (0, length turns - 1) g+
+ src/AI/Utils.hs view
@@ -0,0 +1,41 @@+-- | Utilities for AI players.+module AI.Utils+  ( winNext+  , boardHeuristic+  , pruneBoardTree+  ) where++import Data.Function+import Data.List++import Board++-- | Searches BoardTree to a depth of 1 looking for a guaranteed win.+winNext :: Strategy -> Strategy+winNext s (BoardTree a b branches) = s $ BoardTree a b $ if null winning then branches else [head winning]+  where+  winning = [ (t, b) | (t, b@(BoardTree _ _ [])) <- branches ]++-- | Applies board heuristic to all next board states.  Selects the turn at achieves the board with the lowest cost function.+boardHeuristic :: Ord a => (Board -> a) -> Strategy+boardHeuristic cost (BoardTree _ _ branches) g = (optimalTurn, g)+  where+  turns = [ (t, cost board) | (t, BoardTree _ board _) <- branches ]+  (optimalTurn, _) = minimumBy (compare `on` snd) turns++-- | Prunes the board tree with a board predicate.  If pruning removes all turns, no pruning is done.+pruneBoardTree :: (Board -> Bool) -> BoardTree -> BoardTree+pruneBoardTree f bt@(BoardTree a b branches) = if null branches' then bt else BoardTree a b branches'+  where+  branches' = [ (t, bt) | (t, bt@(BoardTree _ b _)) <- branches, f b ]++++  {-+  losing  = [ t | (t, (BoardTree _ _ branches)) <- branches, (_, (BoardTree _ _ [])) <- branches ]+  branches1 = if not $ null winning+    then [head winning]+    else if length branches < 100 then [ (t, b) | (t, b) <- branches, notElem t losing ] else branches+  branches2 = if null branches1 then [head branches] else branches1+  -}+
+ src/Board.hs view
@@ -0,0 +1,232 @@+-- | Board State and AI+module Board+  (+  -- * Types+    Board+  , BoardTree (..)+  , Type (..)+  , Piece+  , Position (..)+  , Move+  , Turn+  , AtPosition+  , Strategy+  , AI (..)+  -- * Utilities+  , boardTree+  , swapBoardTree+  , connectedPositions+  , threeLines+  , sixLines+  , atPosition+  , startingBoard+  , showTurn+  , showMove+  , applyMove+  ) where++import Data.List+import System.Random++-- | Board state is a list of pieces of you and oppenent.+type Board = ([Piece], [Piece])++-- | The board tree of all future moves.  Bool true if you, false if opponent.+data BoardTree = BoardTree Bool Board [(Turn, BoardTree)]++-- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.+data Type = Tzaar | Tzarra | Tott deriving (Show, Eq)++-- | Position on the board, the type of piece, and the level of the stack (starting with 1).+type Piece = (Position, Type, Int)++-- | Board position.  Letters left to right, numbers bottom to top.+--   Column E has the hole in the middle.+data Position+  = A1 | A2 | A3 | A4 | A5+  | B1 | B2 | B3 | B4 | B5 | B6+  | C1 | C2 | C3 | C4 | C5 | C6 | C7+  | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8+  | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8+  | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8+  | G1 | G2 | G3 | G4 | G5 | G6 | G7+  | H1 | H2 | H3 | H4 | H5 | H6+  | I1 | I2 | I3 | I4 | I5+  deriving (Show, Eq)++-- | A move is one position to another, for either capturing or stacking.+type Move = (Position, Position)++-- | A complete turn is move, followed by an optional move.+type Turn = (Move, Maybe Move)++-- | An AI strategy calculates then next turn from a board tree.+type Strategy = BoardTree -> StdGen -> (Turn, StdGen)++-- | An AI player.+data AI = AI+  { name        :: String   -- ^ Name of AI.+  , description :: String   -- ^ Brief description of AI.+  , strategy    :: Strategy -- ^ The strategy.+  }++-- | The state of a single board position.  Bool true if you, false if opponent.+type AtPosition = (Bool, Type, Int)++showTurn :: Turn -> String+showTurn (a, Nothing) = showMove a+showTurn (a, Just b ) = showMove a ++ "    " ++ showMove b++showMove :: Move -> String+showMove (a, b) = show a ++ " -> " ++ show b++-- | Possible next turns.+nextTurns :: Board -> [Turn]+nextTurns board@(you, _)+  | lostOneOfThree = []+  | otherwise      = captureCapture ++ captureStack ++ captureNothing+  where+  a = nextCaptureMoves board+  b = map (applyMove board) a+  c = map nextCaptureMoves  b+  d = map nextStackingMoves b+  captureCapture = [ (a, Just b) | (a, x) <- zip a c, b <- x ]+  captureStack   = [ (a, Just b) | (a, x) <- zip a d, b <- x ]+  captureNothing = zip a $ repeat Nothing+  lostOneOfThree = length (nub [ t | (_, t, _) <- you ]) /= 3++nextCaptureMoves :: Board -> [Move]+nextCaptureMoves board@(you, _) = concatMap forPiece you+  where+  forPiece :: Piece -> [Move]+  forPiece (p, _, i) = concatMap downLine $ sixLines p+    where+    downLine :: [Position] -> [Move]+    downLine [] = []+    downLine (a:b) = case atPosition board a of+      Nothing -> downLine b+      Just (True,  _, _) -> []+      Just (False, _, j) -> if i >= j then [(p, a)] else []++nextStackingMoves :: Board -> [Move]+nextStackingMoves board@(you, _) = concatMap forPiece you+  where+  forPiece :: Piece -> [Move]+  forPiece (p, _, _) = concatMap downLine $ sixLines p+    where+    downLine :: [Position] -> [Move]+    downLine [] = []+    downLine (a:b) = case atPosition board a of+      Nothing   -> downLine b+      Just (False, _, _) -> []+      Just (True, Tzaar,  _) | oneTzaarRemaining  -> []+      Just (True, Tzarra, _) | oneTzarraRemaining -> []+      Just (True, Tott,   _) | oneTottRemaining   -> []+      Just (True, _, _) -> [(p, a)]+  oneTzaarRemaining  = 1 == length [ () | (_, t, _) <- you, t == Tzaar  ]+  oneTzarraRemaining = 1 == length [ () | (_, t, _) <- you, t == Tzarra ]+  oneTottRemaining   = 1 == length [ () | (_, t, _) <- you, t == Tott   ]++-- Creates a board tree for you and opponent.  Assumes you have the next turn.+boardTree :: Board -> BoardTree+boardTree board = boardTree True True board+  where+  boardTree :: Bool -> Bool -> Board -> BoardTree+  boardTree first you board = BoardTree you (if you then board else swapBoard board) [ (t, boardTree False (not you) $ swapBoard $ applyTurn board t) | t <- nextTurns board, imply first (snd t == Nothing) ]+  imply a b = not a || b++-- | Swaps board positions, i.e. white to black, black to white.+swapBoard :: Board -> Board+swapBoard (a, b) = (b, a)++-- | Swaps board trees, i.e. white to black, black to white.+swapBoardTree :: BoardTree -> BoardTree+swapBoardTree (BoardTree you board branches) = BoardTree (not you) (swapBoard board) [ (t, swapBoardTree bt) | (t, bt) <- branches ]+++-- Querying the state of a board position.+atPosition :: Board -> Position -> Maybe AtPosition +atPosition (you, opp) pos = if null a then Nothing else Just $ head a+  where+  a = [ (True, t, i) | (p, t, i) <- you, p == pos ] ++ [ (False, t, i) | (p, t, i) <- opp, p == pos ]++-- | All the lines that form connected positions on the board.+connectedPositions :: [[Position]]+connectedPositions =+  [ [A1, A2, A3, A4, A5]+  , [B1, B2, B3, B4, B5, B6]+  , [C1, C2, C3, C4, C5, C6, C7]+  , [D1, D2, D3, D4, D5, D6, D7, D8]+  , [E1, E2, E3, E4]+  , [E5, E6, E7, E8]+  , [F1, F2, F3, F4, F5, F6, F7, F8]+  , [G1, G2, G3, G4, G5, G6, G7]+  , [H1, H2, H3, H4, H5, H6]+  , [I1, I2, I3, I4, I5]++  , [A1, B1, C1, D1, E1]+  , [A2, B2, C2, D2, E2, F1]+  , [A3, B3, C3, D3, E3, F2, G1]+  , [A4, B4, C4, D4, E4, F3, G2, H1]+  , [A5, B5, C5, D5]+  , [F4, G3, H2, I1]+  ,     [B6, C6, D6, E5, F5, G4, H3, I2]+  ,         [C7, D7, E6, F6, G5, H4, I3]+  ,             [D8, E7, F7, G6, H5, I4]+  ,                 [E8, F8, G7, H6, I5]+   +  ,                 [E1, F1, G1, H1, I1]+  ,             [D1, E2, F2, G2, H2, I2]+  ,         [C1, D2, E3, F3, G3, H3, I3]+  ,     [B1, C2, D3, E4, F4, G4, H4, I4]+  , [A1, B2, C3, D4]+  , [F5, G5, H5, I5]+  , [A2, B3, C4, D5, E5, F6, G6, H6]+  , [A3, B4, C5, D6, E6, F7, G7]+  , [A4, B5, C6, D7, E7, F8]+  , [A5, B6, C7, D8, E8]+  ]++-- | The three lines that cross at a single board position.+threeLines :: Position -> [[Position]]+threeLines p = [ line | line <- connectedPositions, elem p line ]++-- | The six lines traveling radially out from a single board position.+sixLines :: Position -> [[Position]]+sixLines p = concatMap f $ threeLines p where f l = [a, b] where (a, b) = divide p l++divide :: Eq a => a -> [a] -> ([a], [a])+divide a b = (reverse x, if null y then [] else tail y) where (x, y) = span (/= a) b++-- | The default (non-randomized, non-tournament) starting position.+startingBoard :: Board+startingBoard = (whites, blacks)+  where+  f t p = (p, t, 1)+  whites = map (f Tzaar) wTzaars ++ map (f Tzarra) wTzarras ++ map (f Tott) wTotts+  blacks = map (f Tzaar) bTzaars ++ map (f Tzarra) bTzarras ++ map (f Tott) bTotts+  wTzaars  = [D3, E3, G4, G5, C5, D6]+  wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7]+  wTotts   = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]+  bTzaars  = [C3, C4, F3, G3, E6, F6]+  bTzarras = [B2, B3, B4, F2, G2, H2, E7, F7, G6]+  bTotts   = [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, G7, H6, D4, E5, F4]++-- | The next board state after a move.  Assumes move is valid.+applyMove :: Board -> Move -> Board+applyMove board@(a, b) (x, y) = (a', b')+  where+  Just (whoX, typeX, sizeX) = atPosition board x+  Just (whoY, _    , sizeY) = atPosition board y+  capture = whoX /= whoY+  fromA = null [ () | (p, _, _) <- b, p == x ]+  fromB = not fromA+  piece = (y, typeX, if capture then sizeX else sizeX + sizeY)+  a' = [ m | m@(p, _, _) <- a, p /= x, p /= y ] ++ if fromA then [piece] else []+  b' = [ m | m@(p, _, _) <- b, p /= x, p /= y ] ++ if fromB then [piece] else []++-- | The next board state after a complete turn.  Assumes turn is valid.+applyTurn :: Board -> Turn -> Board+applyTurn board (a, Just b ) = applyMove (applyMove board a) b+applyTurn board (a, Nothing) =            applyMove board a+
+ src/Play.hs view
@@ -0,0 +1,350 @@+module Play+  ( play+  ) where++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Word+import Graphics.Rendering.OpenGL+import Graphics.UI.SDL hiding (init, Color)+import qualified Graphics.UI.SDL as SDL+import System.Random++import Board hiding (Position)+import qualified Board as B++data State = State+  { bt      :: BoardTree+  , history :: [State]+  , stdGen  :: StdGen+  , ai      :: AI+  , stage   :: Stage+  }++data Stage+  = A+  | B  B.Position+  | C Move+  | D Move B.Position+  | E+++initState g ai = State+  { bt      = boardTree startingBoard+  , history = []+  , stdGen  = g+  , ai      = ai+  , stage   = A+  }++play :: StdGen -> AI -> IO ()+play g ai = do+  SDL.init [InitVideo]+  setCaption "htzaar" "htzaar"+  glSetAttribute glRedSize   8+  glSetAttribute glGreenSize 8+  glSetAttribute glBlueSize  8+  glSetAttribute glAlphaSize 8+  glSetAttribute glDepthSize 24+  glSetAttribute glDoubleBuffer 1+  setView 600 400+  cullFace  $= Nothing++  clearColor $= Color4 (255/255) (246/255) (143/255) 0+  clearDepth $= 1+  depthMask  $= Disabled+  loop $ initState g ai+  quit++setView :: Int -> Int -> IO ()+setView w h = do+  setVideoMode w h 16 [OpenGL, Resizable] >> return ()+  matrixMode $= Projection+  loadIdentity+  let r = (fromIntegral w / fromIntegral h)+  ortho (-r) r (-1) 1 (-1) 1+  matrixMode $= Modelview 0+  viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))++redraw :: State -> IO ()+redraw state = do+  clear [ColorBuffer, DepthBuffer] +  loadIdentity+  scale3 0.2 0.2 1+  grid+  case stage state of+    A     -> pieces board+    B p   -> highlightPosition p >> pieces board+    C m   -> pieces $ applyMove board m+    D m p -> highlightPosition p >> pieces (applyMove board m)+    E     -> pieces board+  flush+  glSwapBuffers+  where+  BoardTree _ board _ = bt state++++loop :: State -> IO ()+loop state = do+  event <- pollEvent+  state <- handler event state+  when (event /= Quit) $ loop state++handler :: Event -> State -> IO State+handler event state = case event of+  NoEvent         -> return state+  VideoExpose     -> redraw state >> return state+  VideoResize x y -> setView x y >> return state+  MouseButtonDown x y ButtonLeft -> do+    r <- clickPosition x y+    s <- userSelectedPosition r state+    redraw s+    return s+  MouseButtonDown _ _ ButtonRight -> case history state of+    []    -> return state+    (a:_) -> redraw a >> return a+  KeyDown (key) | symKey key == SDLK_SPACE -> do+    s <- userSelectedPass state+    redraw s+    return s+  _ -> return state++mousePosition :: Word16 -> Word16 -> IO (Float, Float)+mousePosition x y = do+    mm <- get $ matrix $ Just $ Modelview 0+    pm <- get $ matrix $ Just Projection+    vp <- get $ viewport+    Vertex3 x y _ <- unProject (Vertex3 (fromIntegral x) (fromIntegral y) 0) (mm :: GLmatrix GLdouble) (pm :: GLmatrix GLdouble) vp+    return (realToFrac x, realToFrac (-y))++clickPosition :: Word16 -> Word16 -> IO (Maybe B.Position)+clickPosition x y = do+  (x, y) <- mousePosition x y+  let (p, d) = minimumBy (compare `on` snd) [ (p, sqrt ((x - x') ^^ 2 + (y - y') ^^ 2)) | (p, (x', y')) <- boardPositions ]+  return (if d < 0.4 then Just p else Nothing)++userSelectedPosition :: Maybe B.Position -> State -> IO State+userSelectedPosition Nothing  s = case stage s of+  E -> newGame s+  _ -> return s+userSelectedPosition (Just p) s = case stage s of+  A      | or  [ True | ((a, _), _)      <- turns, a == p           ] -> return s { history = s : history s, stage = B p       }+  B p1   | all (\ (_, a) -> a == Nothing) turns                       -> applyTurn ((p1, p), Nothing) s+         | or  [ True | (a, _)           <- turns, a == (p1, p)     ] -> return s { history = s : history s, stage = C (p1, p) }+  C m    | or  [ True | (a, Just (b, _)) <- turns, a == m, b == p   ] -> return s { history = s : history s, stage = D m p     } +  D m p1 | elem t turns                                               -> applyTurn t s+    where+    t = (m, Just (p1, p))+  E -> newGame s+  _ -> return s+  where+  BoardTree _ _ branches = bt s+  turns = fst $ unzip branches++userSelectedPass :: State -> IO State+userSelectedPass s = case stage s of+  C m | elem (m, Nothing) turns -> applyTurn (m, Nothing) s+  _ -> return s+  where+  BoardTree _ _ branches = bt s+  turns = fst $ unzip branches++applyTurn :: Turn -> State -> IO State+applyTurn t s+  | null branches' = do+    putStrLn $ "white : " ++ showTurn t+    putStrLn "White Wins!"+    return s { history = s : history s, stage = E, bt = swapBoardTree bt', stdGen = g }+  | otherwise      = do+    putStrLn $ "white : " ++ showTurn t+    putStrLn $ "black : " ++ showTurn t'+    if null branches''+      then do+        putStrLn "Black Wins!"+        return s { history = s : history s, stage = E, bt = bt'', stdGen = g }+      else do+        return s { history = s : history s, stage = A, bt = bt'', stdGen = g }+  where+  BoardTree _ _ branches = bt s+  bt'@(BoardTree _ _ branches') = swapBoardTree $ fromJust $ lookup t branches+  (t', g) = strategy (ai s) bt' (stdGen s)+  bt''@(BoardTree _ _ branches'') = swapBoardTree $ case lookup t' branches' of+    Nothing -> error $ "Invalid AI Turn: " ++ show t'+    Just a -> a++newGame :: State -> IO State+newGame s = do+  putStrLn "New Game!"+  return (initState (stdGen s) (ai s)) { history = s : history s }++grid :: IO ()+grid = do+  color3 (128/255) (128/255) (128/255)+  renderPrimitive Polygon $ do+    p A1+    p A5+    p E8+    p I5+    p I1+    p E1+  lineWidth $= 3+  preservingMatrix $ do+    color3  0.1 0.1 0.1+    g+    rotate3 (pi / 3) 0 0 1 >> g+    rotate3 (pi / 3) 0 0 1 >> g+    rotate3 (pi / 3) 0 0 1 >> g+    rotate3 (pi / 3) 0 0 1 >> g+    rotate3 (pi / 3) 0 0 1 >> g+  where+  p a = vertex2 x y where (x, y) = boardPosition a+  g = renderPrimitive Lines $ do+    p E5 >> p E8+    p F1 >> p F8+    p G1 >> p G7+    p H1 >> p H6+    p I1 >> p I5++highlightPosition :: B.Position -> IO ()+highlightPosition p = preservingMatrix $ do+    translate3 x y 0+    color3 0 0 1+    lineWidth $= 2+    ring 0.4+    where+    (x, y) = boardPosition p+  +data PieceColor = White | Black++pieces :: Board -> IO ()+pieces (whites, blacks) = do+  mapM_ (piece White) whites+  mapM_ (piece Black) blacks++piece :: PieceColor -> (B.Position, Type, Int) -> IO ()+piece c (p, t, size) = preservingMatrix $ do+  translate3 x y 0+  scale3 0.3 0.3 1+  lineWidth $= 1+  stack size+  where+  (x, y) = boardPosition p+  (chipColor, lineColor, crownColor) = case c of+    White -> (color3 1 1 1, color3 0 0 0, color3 ( 60/255) ( 60/255) (  0/255))+    Black -> (color3 0 0 0, color3 1 1 1, color3 (255/255) (215/255) (  0/255))+  stack 0 = case t of+    Tott   -> return ()+    Tzarra -> crownColor >> disc 0.25+    Tzaar  -> crownColor >> disc 0.75 >> chipColor >> disc 0.5 >> crownColor >> disc 0.25+  stack n = do+    chipColor >> disc 1+    lineColor >> ring 1+    when (n /= 1) $ translate3 0 0.2 0+    stack $ n - 1++segments :: [Float]+segments = [0, 2 * pi / 24 .. 2 * pi] ++ [0]++disc :: Float -> IO ()+disc a = renderPrimitive TriangleFan $ vertex2 0 0 >> mapM_ (\ p -> vertex2 (a * cos p) (a * sin p)) segments++ring :: Float -> IO ()+ring a = renderPrimitive LineStrip $ mapM_ (\ p -> vertex2 (a * cos p) (a * sin p)) segments+++boardPosition :: B.Position -> (Float, Float)+boardPosition a = fromJust $ lookup a boardPositions++boardPositions :: [(B.Position, (Float, Float))]+boardPositions =+  [ (A1, p (-4) (-2))+  , (A2, p (-4) (-1))+  , (A3, p (-4) ( 0))+  , (A4, p (-4) ( 1))+  , (A5, p (-4) ( 2))+  , (B1, p (-3) (-3))+  , (B2, p (-3) (-2))+  , (B3, p (-3) (-1))+  , (B4, p (-3) ( 1))+  , (B5, p (-3) ( 2))+  , (B6, p (-3) ( 3))+  , (C1, p (-2) (-3))+  , (C2, p (-2) (-2))+  , (C3, p (-2) (-1))+  , (C4, p (-2) ( 0))+  , (C5, p (-2) ( 1))+  , (C6, p (-2) ( 2))+  , (C7, p (-2) ( 3))+  , (D1, p (-1) (-4))+  , (D2, p (-1) (-3))+  , (D3, p (-1) (-2))+  , (D4, p (-1) (-1))+  , (D5, p (-1) ( 1))+  , (D6, p (-1) ( 2))+  , (D7, p (-1) ( 3))+  , (D8, p (-1) ( 4))+  , (E1, p ( 0) (-4))+  , (E2, p ( 0) (-3))+  , (E3, p ( 0) (-2))+  , (E4, p ( 0) (-1))+  , (E5, p ( 0) ( 1))+  , (E6, p ( 0) ( 2))+  , (E7, p ( 0) ( 3))+  , (E8, p ( 0) ( 4))+  , (F1, p ( 1) (-4))+  , (F2, p ( 1) (-3))+  , (F3, p ( 1) (-2))+  , (F4, p ( 1) (-1))+  , (F5, p ( 1) ( 1))+  , (F6, p ( 1) ( 2))+  , (F7, p ( 1) ( 3))+  , (F8, p ( 1) ( 4))+  , (G1, p ( 2) (-3))+  , (G2, p ( 2) (-2))+  , (G3, p ( 2) (-1))+  , (G4, p ( 2) ( 0))+  , (G5, p ( 2) ( 1))+  , (G6, p ( 2) ( 2))+  , (G7, p ( 2) ( 3))+  , (H1, p ( 3) (-3))+  , (H2, p ( 3) (-2))+  , (H3, p ( 3) (-1))+  , (H4, p ( 3) ( 1))+  , (H5, p ( 3) ( 2))+  , (H6, p ( 3) ( 3))+  , (I1, p ( 4) (-2))+  , (I2, p ( 4) (-1))+  , (I3, p ( 4) ( 0))+  , (I4, p ( 4) ( 1))+  , (I5, p ( 4) ( 2))+  ]+  where+  p :: Int -> Int -> (Float, Float)+  p x y = (x', y')+    where+    x' = fromIntegral x * sin (pi / 3)+    y' | even x    = fromIntegral y+       | otherwise = fromIntegral y - (fromIntegral (signum y) * 0.5)++++--vertex3 :: Real a => a -> a -> a -> IO ()+vertex2 x y = vertex $ Vertex3 (toFloat x) (toFloat y) 0++--color3 :: Real a => a -> a -> a -> IO ()+color3 r g b = color $ Color3 (toFloat r) (toFloat g) (toFloat b)++--scale3 :: Real a => a -> a -> a -> IO ()+scale3 x y z = scale (toFloat x) (toFloat y) (toFloat z)++--translate3 :: Real a => a -> a -> a -> IO ()+translate3 x y z = translate $ Vector3 (toFloat x) (toFloat y) (toFloat z)++--rotate3 :: (Real a, Floating a) => a -> a -> a -> a -> IO ()+rotate3 angle x y z = rotate (toFloat $ angle * 180 / pi) $ Vector3 (toFloat x) (toFloat y) (toFloat z)++toFloat :: (Real a, Floating a) => a -> GLfloat+toFloat = realToFrac