diff --git a/1/10.png b/1/10.png new file mode 100644 Binary files /dev/null and b/1/10.png differ diff --git a/1/20.png b/1/20.png new file mode 100644 Binary files /dev/null and b/1/20.png differ diff --git a/1/30.png b/1/30.png new file mode 100644 Binary files /dev/null and b/1/30.png differ diff --git a/1/40.png b/1/40.png new file mode 100644 Binary files /dev/null and b/1/40.png differ diff --git a/1/50.png b/1/50.png new file mode 100644 Binary files /dev/null and b/1/50.png differ diff --git a/1/60.png b/1/60.png new file mode 100644 Binary files /dev/null and b/1/60.png differ diff --git a/1/70.png b/1/70.png new file mode 100644 Binary files /dev/null and b/1/70.png differ diff --git a/1/80.png b/1/80.png new file mode 100644 Binary files /dev/null and b/1/80.png differ diff --git a/1/90.png b/1/90.png new file mode 100644 Binary files /dev/null and b/1/90.png differ diff --git a/2/10.png b/2/10.png new file mode 100644 Binary files /dev/null and b/2/10.png differ diff --git a/2/20.png b/2/20.png new file mode 100644 Binary files /dev/null and b/2/20.png differ diff --git a/2/30.png b/2/30.png new file mode 100644 Binary files /dev/null and b/2/30.png differ diff --git a/2/40.png b/2/40.png new file mode 100644 Binary files /dev/null and b/2/40.png differ diff --git a/2/50.png b/2/50.png new file mode 100644 Binary files /dev/null and b/2/50.png differ diff --git a/2/60.png b/2/60.png new file mode 100644 Binary files /dev/null and b/2/60.png differ diff --git a/2/70.png b/2/70.png new file mode 100644 Binary files /dev/null and b/2/70.png differ diff --git a/2/80.png b/2/80.png new file mode 100644 Binary files /dev/null and b/2/80.png differ diff --git a/2/90.png b/2/90.png new file mode 100644 Binary files /dev/null and b/2/90.png differ diff --git a/3/10.png b/3/10.png new file mode 100644 Binary files /dev/null and b/3/10.png differ diff --git a/3/20.png b/3/20.png new file mode 100644 Binary files /dev/null and b/3/20.png differ diff --git a/3/30.png b/3/30.png new file mode 100644 Binary files /dev/null and b/3/30.png differ diff --git a/3/40.png b/3/40.png new file mode 100644 Binary files /dev/null and b/3/40.png differ diff --git a/3/50.png b/3/50.png new file mode 100644 Binary files /dev/null and b/3/50.png differ diff --git a/3/60.png b/3/60.png new file mode 100644 Binary files /dev/null and b/3/60.png differ diff --git a/3/70.png b/3/70.png new file mode 100644 Binary files /dev/null and b/3/70.png differ diff --git a/3/80.png b/3/80.png new file mode 100644 Binary files /dev/null and b/3/80.png differ diff --git a/3/90.png b/3/90.png new file mode 100644 Binary files /dev/null and b/3/90.png differ diff --git a/Cache.hs b/Cache.hs new file mode 100644 --- /dev/null +++ b/Cache.hs @@ -0,0 +1,36 @@ +module Cache where +import System.IO.Unsafe +import Data.IORef +import qualified Data.Map as M + +type Cache k a = IORef (M.Map k a) +type CacheOnce k a = IORef (Maybe (k, a)) + +initCache :: IO a -> a +initCache = unsafePerformIO + +newCache :: (Eq k, Ord k) => IO (Cache k a) +newCache = newIORef (M.empty) + +newCacheOnce :: Eq k => IO (CacheOnce k a) +newCacheOnce = newIORef Nothing + +cacheOnce :: Eq k => CacheOnce k a -> (k -> IO a) -> k -> IO a +cacheOnce ref f key = do + m <- readIORef ref + case m of + Just (k, v) | k == key -> return v + _ -> do + v <- f key + writeIORef ref (Just (key, v)) + return v + +cache :: (Eq k, Ord k) => Cache k a -> (k -> IO a) -> k -> IO a +cache ref f key = do + m <- readIORef ref + case M.lookup key m of + Just v -> return v + _ -> do + v <- f key + modifyIORef ref (M.insert key v) + return v diff --git a/Check.hs b/Check.hs new file mode 100644 --- /dev/null +++ b/Check.hs @@ -0,0 +1,40 @@ +module Check where +import Data.List (sort) +import Tiles +import Render +import Test.LazySmallCheck + +instance Serial Point where + series = cons2 MkPoint + +prop_tiling points = + toPointSet points == + toPointSet (tilePoints $ makeTiles points) + +main = do + pts <- renderChar "test.ttf" 24 '龍' + print pts + putStrLn $ showPoints pts + tiles <- makeRandomTiles pts + putStrLn . showTiles $ tiles + putStrLn . showPoints $ tilePoints tiles + +sampleTiles :: Tiles +sampleTiles = concat + [ [(MkPoint x 0, 1) | x <- [0..4]] + , [(MkPoint x 1, 2) | x <- [0..5]] + , [(MkPoint x 2, 3) | x <- [2..7]] + , [(MkPoint x 3, 1) | x <- [3..7]] + ] + +samplePoints' :: [Point] +samplePoints' = concat + [ [MkPoint x 0 | x <- [0..4]] + , [MkPoint x 1 | x <- [0..5]] + , [MkPoint x 2 | x <- [2..7]] + , [MkPoint x 3 | x <- [3..7]] + ] + +samplePoints = + [MkPoint {pointX = 0, pointY = 1},MkPoint {pointX = 0, pointY = 0},MkPoint {pointX = 0, pointY = 0},MkPoint {pointX = 1, pointY = 0},MkPoint {pointX = 1, pointY = 1} + ] diff --git a/HSMain.hs b/HSMain.hs new file mode 100644 --- /dev/null +++ b/HSMain.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module HSMain where + +import Main + +foreign export ccall hs_main :: IO () + +hs_main :: IO () +hs_main = main diff --git a/HSMain_stub.c b/HSMain_stub.c new file mode 100644 --- /dev/null +++ b/HSMain_stub.c @@ -0,0 +1,24 @@ +#define IN_STG_CODE 0 +#include "Rts.h" +#include "Stg.h" +#ifdef __cplusplus +extern "C" { +#endif + +extern StgClosure HSMain_zdfhszumainzuatN_closure; +void hs_main(void) +{ +Capability *cap; +HaskellObj ret; +cap = rts_lock(); +cap=rts_evalIO(cap,rts_apply(cap,(HaskellObj)runIO_closure,&HSMain_zdfhszumainzuatN_closure) ,&ret); +rts_checkSchedStatus("hs_main",cap); +rts_unlock(cap); +} +static void stginit_export_HSMain_zdfhszumainzuatN() __attribute__((constructor)); +static void stginit_export_HSMain_zdfhszumainzuatN() +{getStablePtr((StgPtr) &HSMain_zdfhszumainzuatN_closure);} +#ifdef __cplusplus +} +#endif + diff --git a/HSMain_stub.h b/HSMain_stub.h new file mode 100644 --- /dev/null +++ b/HSMain_stub.h @@ -0,0 +1,9 @@ +#include "HsFFI.h" +#ifdef __cplusplus +extern "C" { +#endif +extern void hs_main(void); +#ifdef __cplusplus +} +#endif + diff --git a/Image.hs b/Image.hs new file mode 100644 --- /dev/null +++ b/Image.hs @@ -0,0 +1,51 @@ +module Image where +import Internals (setScreenWidth, setScreenHeight, getDataFileName) +import Cache +import Point +import Zoom +import Graphics.UI.SDL as SDL +import qualified Graphics.UI.SDL.TTF as TTF +import qualified Graphics.UI.SDL.Image as SDLImage +import qualified Graphics.UI.SDL.Rotozoomer as SDLRotozoomer + +initSDL :: (Surface -> IO a) -> IO () +initSDL f = SDL.withInit [InitTimer, InitAudio, InitVideo] $ do + info <- getVideoInfo + let w = videoInfoWidth info + h = videoInfoHeight info + setScreenWidth w + setScreenHeight h + screen <- setVideoMode w h 32 + [AnyFormat, Fullscreen, HWAccel, HWSurface, DoubleBuf] + TTF.init + f screen + TTF.quit + +blitTile :: (Show a) => X -> Y -> Surface -> a -> Zoom -> (Point, Int) -> IO Bool +blitTile xOff yOff canvas seed z (MkPoint x y, sz) = do + img <- loadImageSized (show seed, (sz * 9) *** z) + let x' = x * 9 + xOff + y' = y * 12 + yOff + pos = Just (Rect (x' ~~~ z) (y' ||| z) 0 0) + blitSurface img Nothing canvas pos + +{-# NOINLINE _loadImage #-} +_loadImage :: Cache FilePath Surface +_loadImage = initCache newCache +loadImage :: FilePath -> IO Surface +loadImage = cache _loadImage SDLImage.load + +{-# NOINLINE _loadImageSized #-} +_loadImageSized :: Cache (String, Int) Surface +_loadImageSized = initCache newCache +loadImageSized :: (String, Int) -> IO Surface +loadImageSized = cache _loadImageSized $ \(fn, sz) -> do + -- Round to nearest multiples of 10 + img <- getDataFileName $ fn ++ "/" ++ show ((sz + 9) `div` 10) ++ "0.png" + src <- loadImage img + let r = (fromIntegral sz + 0.5) / fromIntegral srcWidth + srcWidth = SDL.surfaceGetWidth src + if srcWidth == sz + then return src + else SDLRotozoomer.zoom src r r True + diff --git a/Internals.hs b/Internals.hs new file mode 100644 --- /dev/null +++ b/Internals.hs @@ -0,0 +1,35 @@ +module Internals ( getDataFileName, module Internals ) where +import Paths_TimePiece +import System.IO.Unsafe +import Data.IORef + +{-# NOINLINE _WIDTH_ #-} +_WIDTH_ :: IORef Integer +_WIDTH_ = unsafePerformIO $ newIORef 1024 + +{-# NOINLINE _HEIGHT_ #-} +_HEIGHT_ :: IORef Integer +_HEIGHT_ = unsafePerformIO $ newIORef 768 + +getScreenWidth :: Num a => IO a +getScreenWidth = fmap fromIntegral (readIORef _WIDTH_) + +getScreenHeight :: Num a => IO a +getScreenHeight = fmap fromIntegral (readIORef _HEIGHT_) + +setScreenWidth :: Integral a => a -> IO () +setScreenWidth = writeIORef _WIDTH_ . toInteger + +setScreenHeight :: Integral a => a -> IO () +setScreenHeight = writeIORef _HEIGHT_ . toInteger + +type X = Int +type Y = Int +type Size = Int + +data Point = MkPoint + { pointX :: !X + , pointY :: !Y + } + deriving (Show, Eq, Ord) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright 2008 by Audrey Tang + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,126 @@ +module Main where +import System.Time +import System.Random +import System.Locale +import Control.Monad +import Graphics.UI.SDL as SDL + +import Internals (getScreenWidth, getScreenHeight, getDataFileName) +import Zoom +import Image +import Tiles +import Render +import Cache + +data Status + = Static { sTime :: String } + | ZoomIn { sTime :: String, sZoom :: Zoom, sSpeed :: Speed } + | ZoomOut { sTime :: String, sZoom :: Zoom, sSpeed :: Speed } + +main :: IO () +main = initSDL $ \screen -> loop (Static "") $ \status -> do + time' <- getCurrentTime + case status of + Static{ sTime = t } | t == time' -> do + SDL.delay 50 + return status + Static{} -> do + paintScreen screen time' noZoom + if last time' == '0' + then initZoomIn time' + else return status{ sTime = time' } + ZoomIn{ sZoom = z, sSpeed = s } -> do + paintScreen screen time' z + -- print $ z + let ratio' = fixRatio $ ratio z + s + return $ if ratio z >= maxBound + then ZoomOut + { sTime = time' + , sZoom = z + , sSpeed = 0.05 + } + else status + { sTime = time' + , sZoom = z{ ratio = ratio' } + , sSpeed = (maxBound - ratio z) / 50 + 0.01 + } + ZoomOut{ sZoom = z, sSpeed = s } -> do + paintScreen screen time' z + let ratio' = fixRatio $ ratio z - s + return $ if ratio z <= minBound + then Static{ sTime = time' } + else status + { sTime = time' + , sZoom = z{ ratio = ratio' } + } + +data Tiling = MkTiling + { tTiles :: Tiles + , tSeeds :: [Int] + , tEdge :: Point + } + +{-# NOINLINE _calculateTiling #-} +_calculateTiling :: CacheOnce String [Tiling] +_calculateTiling = initCache newCacheOnce +calculateTiling :: String -> IO [Tiling] +calculateTiling = cacheOnce _calculateTiling $ \time -> forM time $ \ch -> do + ttf <- getDataFileName "TimePiece.ttf" + pts <- renderChar ttf 22 ch + tiling <- makeRandomTiles pts + seeds <- forM tiling . const $ randomRIO (1, 3) + return $ MkTiling tiling seeds (edgePoint (toPointSet pts)) + +paintScreen :: Surface -> String -> Zoom -> IO () +paintScreen screen time zoom = do + w <- getScreenWidth + h <- getScreenHeight + bgColor <- mapRGB (surfaceGetPixelFormat screen) 0x00 0x00 0x33 + fillRect screen Nothing bgColor + rvs <- calculateTiling time + let maxX = 10 -- maximum (map pointX edges) + maxY = maximum (map pointY edges) + edges = map tEdge rvs + forM_ ([0..] `zip` rvs) $ \(n, MkTiling tiles seeds edge) -> do + let tiles' = map adjust tiles + adjust (MkPoint x y, sz) = (MkPoint (x + deltaX) (y + deltaY), sz) + deltaX = (maxX - pointX edge + 1) `div` 2 + 1 + deltaY = (maxY - pointY edge + 1) `div` 2 + 1 + forM_ (tiles' `zip` seeds) $ \(tile, seed) -> do + let x = (((16 * 15 * n) `div` 2) + ((w - 964) `div` 2)) + y = (h - 288) `div` 2 + blitTile x y screen seed zoom tile + SDL.flip screen + +getCurrentTime :: IO String +getCurrentTime = do + fmap (formatCalendarTime defaultTimeLocale "%H:%M:%S") + . toCalendarTime =<< getClockTime + +loop :: Status -> (Status -> IO Status) -> IO () +loop x f = f x >>= \x' -> do + event <- pollEvent + case event of + Quit -> return () + KeyDown (Keysym SDLK_SPACE _ _) -> do + status <- initZoomIn (sTime x') + loop status f + KeyDown (Keysym SDLK_k _ _) -> loop x' f + KeyDown{} -> return () + MouseButtonDown{} -> return () + _ -> loop x' f + +initZoomIn :: String -> IO Status +initZoomIn time' = do + w <- getScreenWidth + h <- getScreenHeight + xf <- randomRIO (0, w) + yf <- randomRIO ((h `div` 2)-96, (h `div` 2)+96) + return $ ZoomIn + { sZoom = MkZoom + { ratio = 1 + , focus = MkPoint xf yf + } + , sTime = time' + , sSpeed = 0 + } diff --git a/Point.hs b/Point.hs new file mode 100644 --- /dev/null +++ b/Point.hs @@ -0,0 +1,12 @@ +module Point where + +type X = Int +type Y = Int +type Size = Int + +data Point = MkPoint + { pointX :: !X + , pointY :: !Y + } + deriving (Show, Eq, Ord) + diff --git a/Render.hs b/Render.hs new file mode 100644 --- /dev/null +++ b/Render.hs @@ -0,0 +1,36 @@ +module Render where +import Foreign +import Point +import qualified Graphics.UI.SDL as SDL +import qualified Graphics.UI.SDL.TTF as TTF + +type FontName = FilePath + +renderChar :: FontName -> Size -> Char -> IO [Point] +renderChar fn size ch = do + font <- TTF.openFont fn size + Just textImage <- TTF.tryRenderGlyphSolid font ch white + let width = SDL.surfaceGetWidth textImage + height = SDL.surfaceGetHeight textImage + pixels <- SDL.surfaceGetPixels textImage + vals <- peekArray (width * height) (castPtr pixels) + + let points = [ MkPoint x y | y <- [0..(height-1)], x <- [0..(width-1)] ] + + return [ pt | (pt, v) <- points `zip` vals, v > (0 :: Word8) ] + +white :: SDL.Color +white = SDL.Color 255 255 255 + +showPixels :: SDL.Surface -> IO String +showPixels surface = do + pixels <- SDL.surfaceGetPixels surface + let width = SDL.surfaceGetWidth surface + height = SDL.surfaceGetHeight surface + format = SDL.surfaceGetPixelFormat surface + bpp <- SDL.pixelFormatGetBytesPerPixel format + vals <- peekArray (fromEnum bpp * width * height) (castPtr pixels) + let part [] = [] + part xs = let (r, rs) = splitAt width xs in (r:part rs) + return . unlines $ map (map (\x -> if x > (0 :: Word8) then '*' else ' ')) (part vals) + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Tiles.hs b/Tiles.hs new file mode 100644 --- /dev/null +++ b/Tiles.hs @@ -0,0 +1,153 @@ +module Tiles + ( Point(..), PointSet, Tiles + , makeRandomTiles, makeTiles + , tilePoints, showTiles, showPoints + , toPointSet, fromPointSet, showPointSet, edgePoint + ) where +import Point +import System.Random +import Data.List (find) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +type Tiles = [(Point, Size)] + +-- Map from -X to existence of -Y +type PointSet = IM.IntMap IS.IntSet + +tilePoints :: Tiles -> [Point] +tilePoints [] = [] +tilePoints ((p@(MkPoint x y), 4):rest) = block ++ (p:tilePoints rest) + where + block = [ MkPoint (x+dx) (y+dy) | (dx, dy) <- _size2 ++ _size3 ++ _size4 ] +tilePoints ((p@(MkPoint x y), 3):rest) = block ++ (p:tilePoints rest) + where + block = [ MkPoint (x+dx) (y+dy) | (dx, dy) <- _size2 ++ _size3 ] +tilePoints ((p@(MkPoint x y), 2):rest) = block ++ (p:tilePoints rest) + where + block = [ MkPoint (x+dx) (y+dy) | (dx, dy) <- _size2 ] +tilePoints ((p, _):rest) = (p:tilePoints rest) + +makeTiles :: [Point] -> Tiles +makeTiles [] = [] +makeTiles points = (m:makeTiles rest') + where + ps = toPointSet points + (m@(_, msz), rest) = case find ((== 4) . snd) tilings of + Just m4 -> (m4, points) + _ -> case find ((== 3) . snd) tilings of + Just m3 -> (m3, points) + _ -> case find ((== 2) . snd) tilings of + Just m2 -> (m2, points) + _ -> ((head points, 1), tail points) + rest' = if msz == 1 then rest else filter (not . inArea m) rest + tilings = [ (p, getTileSize p ps) | p <- points ] + +makeRandomTiles :: [Point] -> IO Tiles +makeRandomTiles = fmap makeTiles . shuffle + +insertPoint :: Point -> PointSet -> PointSet +insertPoint (MkPoint px py) ps = IM.insert x ys' ps + where + x = -px + y = -py + ys' = case IM.lookup x ps of + Just ys -> IS.insert y ys + _ -> IS.singleton y + + +lookupPoint :: Point -> PointSet -> Bool +lookupPoint (MkPoint px py) ps = case IM.lookup x ps of + Just ys -> IS.member y ys + _ -> False + where + x = -px + y = -py + +{- +deletePoint :: Point -> PointSet -> PointSet +deletePoint (MkPoint px py) = IM.update doUpdate x + where + x = -px + y = -py + doUpdate ys = if IS.null ys' then Nothing else Just ys' + where + ys' = IS.delete y ys +-} + +-- At least we have size 1; the goal is to check for bigger sizes. +getTileSize :: Point -> PointSet -> Size +getTileSize (MkPoint x y) ps + | all ok _size2 = if all ok _size3 then if all ok _size4 then 4 else 3 else 2 + | otherwise = 1 + where + ok (dx, dy) = lookupPoint (MkPoint (x+dx) (y+dy)) ps + +_size2, _size3, _size4 :: [(X, Y)] +_size2 = [(1, 0), (0, 1), (1, 1)] +_size3 = [(2, 0), (2, 1), (0, 2), (1, 2), (2, 2)] +_size4 = [(3, 0), (3, 1), (3, 2), (0, 3), (1, 3), (2, 3), (3, 3)] + +-- The bottom right edge of a point set +edgePoint :: PointSet -> Point +edgePoint ps = MkPoint (-x) (-y) + where + x = head (IM.keys ps) + y = minimum $ map (head . IS.elems) (IM.elems ps) + +shuffle :: [a] -> IO [a] +shuffle [] = return [] +shuffle [c] = return [c] +shuffle deck0 = part deck0 [] [] + where + part [] p0 p1 = do + s1 <- shuffle p0 + s2 <- shuffle p1 + return (s1 ++ s2) + part (d : deck) p0 p1 = do + n <- randomRIO (False, True) + if n then part deck (d : p0) p1 + else part deck p0 (d : p1) + +inArea :: (Point, Size) -> Point -> Bool +inArea (MkPoint x y, sz) (MkPoint tx ty) + = dx >= 0 && dx < sz + && dy >= 0 && dy < sz + where + dx = tx - x + dy = ty - y + +-- doMakeTiles :: PointSet -> Tiles + +showTiles :: Tiles -> String +showTiles mosaic = unlines + [ [ case lookup (MkPoint x y) mosaic of + Just sz -> toEnum (48 + sz) + _ -> ' ' + | x <- [0..maxX] + ] + | y <- [0..maxY] + ] + where + pts = map fst mosaic + maxX = maximum (map pointX pts) + maxY = maximum (map pointY pts) + +showPoints :: [Point] -> String +showPoints = showPointSet . toPointSet + +showPointSet :: PointSet -> String +showPointSet ps = unlines + [ [ if lookupPoint (MkPoint x y) ps then '*' else ' ' + | x <- [0..maxX] + ] + | y <- [0..maxY] + ] + where + MkPoint maxX maxY = edgePoint ps + +toPointSet :: [Point] -> PointSet +toPointSet = foldl (flip insertPoint) IM.empty + +fromPointSet :: PointSet -> [Point] +fromPointSet ps = concat [ [ MkPoint x y | y <- IS.elems ys ] | (x, ys) <- IM.assocs ps ] diff --git a/TimePiece.cabal b/TimePiece.cabal new file mode 100644 --- /dev/null +++ b/TimePiece.cabal @@ -0,0 +1,23 @@ +Name: TimePiece +Version: 0.0.1 +Synopsis: A simple tile-based digital clock screen saver +Description: A simple tile-based digital clock screen saver +License: BSD3 +License-File: LICENSE +Category: Screensaver +Author: Audrey Tang +Maintainer: Audrey Tang +Build-Depends: base, SDL >= 0.5.4, SDL-image, SDL-ttf, SDL-gfx, containers, random, old-locale, old-time +Build-Type: Simple +Data-Files: 1/10.png 1/20.png 1/30.png 1/40.png 1/50.png 1/60.png 1/70.png 1/80.png 1/90.png + 2/10.png 2/20.png 2/30.png 2/40.png 2/50.png 2/60.png 2/70.png 2/80.png 2/90.png + 3/10.png 3/20.png 3/30.png 3/40.png 3/50.png 3/60.png 3/70.png 3/80.png 3/90.png + HSMain_stub.c HSMain_stub.h TimePiece.ttf + +Executable: TimePiece +HS-Source-Dirs: . +Main-Is: HSMain.hs +GHC-Options: -no-hs-main -Wall +C-Sources: c_main.c +Extra-Libraries: SDLmain +Other-Modules: Cache Check Image Internals Main Point Render Tiles Zoom diff --git a/TimePiece.ttf b/TimePiece.ttf new file mode 100644 Binary files /dev/null and b/TimePiece.ttf differ diff --git a/Zoom.hs b/Zoom.hs new file mode 100644 --- /dev/null +++ b/Zoom.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Zoom where +import Point + +newtype Ratio = MkRatio { fromRatio :: Double } + deriving (Show, RealFrac, Fractional, Real, Ord, Num, Eq, Enum) +type Speed = Ratio + +data Zoom = MkZoom + { ratio :: !Ratio + , focus :: !Point + } + deriving Show + +noZoom :: Zoom +noZoom = MkZoom 1 (MkPoint 0 0) + +fixRatio :: Ratio -> Ratio +fixRatio = min maxBound . max minBound + +instance Bounded Ratio where + minBound = 1 + maxBound = 2 + +(***) :: (Integral b, Integral a) => a -> Zoom -> b +x *** MkZoom r _ = round (fromIntegral x * r) + +(~~~) :: (Integral b, Integral a) => a -> Zoom -> b +x ~~~ MkZoom r (MkPoint dx _) = + round (fromIntegral x * r + ((fromIntegral dx - 256) * 2 / pred maxBound) * (1-r)) + +(|||) :: (Integral b, Integral a) => a -> Zoom -> b +y ||| MkZoom r (MkPoint _ dy) = + round (fromIntegral y * r + ((fromIntegral dy - 192) * 2 / pred maxBound) * (1-r)) diff --git a/c_main.c b/c_main.c new file mode 100644 --- /dev/null +++ b/c_main.c @@ -0,0 +1,39 @@ +#include +#include "HsFFI.h" + +#ifdef __APPLE__ +#include +#include +#endif + +#include + +#ifdef __GLASGOW_HASKELL__ +#include "HSMain_stub.h" +extern void __stginit_HSMain ( void ); +#endif + +int SDL_main(int argc, char *argv[]) +{ + int i; + +#ifdef __APPLE__ + void * pool = + objc_msgSend(objc_lookUpClass("NSAutoreleasePool"), sel_getUid("alloc")); + objc_msgSend(pool, sel_getUid("init")); +#endif + + hs_init(&argc, &argv); +#ifdef __GLASGOW_HASKELL__ + hs_add_root(__stginit_HSMain); +#endif + + hs_main(); + + hs_exit(); + +#ifdef __APPLE__ + objc_msgSend(pool, sel_getUid("release")); +#endif + return 0; +}