gruff-0.2: src/gruff.hs
{-# LANGUAGE StandaloneDeriving #-}
module Main (main) where
import Prelude hiding (catch, log)
import Control.Monad (forM_, liftM3, when)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
import Data.Maybe (isJust, fromMaybe)
import Graphics.UI.Gtk hiding (get, Region, Size, Window, Viewport)
import qualified Graphics.UI.Gtk as GTK
import Graphics.UI.Gtk.OpenGL (initGL)
import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)
import System.FilePath ((</>))
import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parseAngledInternalAddress, prettyAngledInternalAddress)
import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart)
import Paths_gruff (getDataFileName)
import Number (R)
import Browser (Browser(..), browserNew)
import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)
import View (Image(..), Location(..), Viewport(..), Window(..), Colours(..), Colour(..), defWindow, defViewport)
import GLUTGtk (glut, Size(Size), postRedisplay)
import Logger (logger, LogLevel(Debug))
import qualified Logger as Log
import StatusDialog (StatusDialog, statusDialog, statusDialogNew)
import Utils (safeRead, catchIO)
exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()
exit lg stateFile g = do
lg Debug "exitCallback"
aDoSave stateFile g
mainQuit
data GruffGUI = GruffGUI
{ dStatus :: StatusDialog
-- buttons
, bHome
, bLoad
, bSave
, bStop
, bAddressToCoordinates
, bPeriodScan
, bPeriodScanPlus :: Button
-- entries
, eAddress
, eRealM, eRealE
, eImagM, eImagE
, eSizeM, eSizeE
, eRota
, eWidth
, eHeight
, eSamples :: Entry
-- colour pickers
, cInterior
, cBorder
, cExterior :: ColorButton
-- windows
, wMain
, wImage :: GTK.Window
}
main :: IO ()
main = do
-- contexts
_ <- initGUI
_ <- initGL
gl' <- glut minSize
-- directories
appDir <- getAppUserDataDirectory "gruff"
let cacheDir' = appDir </> "cache"
logDir = appDir </> "log"
stateFile = appDir </> "state.gruff"
createDirectoryIfMissing False appDir
createDirectoryIfMissing False logDir
lg <- logger logDir
icon <- pixbufNewFromFile =<< getDataFileName "icon.png"
browser <- browserNew gl' icon lg cacheDir'
let iw = browserWindow browser
sg <- sizeGroupNew SizeGroupHorizontal
let spacing = 2
entryNewWithMnemonic m = entryNewWithMnemonic' m 30
entryNewWithMnemonic' m wc = do
e <- entryNew
entrySetWidthChars e wc
l <- labelNewWithMnemonic m
labelSetMnemonicWidget l e
sizeGroupAddWidget sg l
h <- hBoxNew False spacing
boxPackStart h l PackNatural 0
boxPackStartDefaults h e
return (e, h)
entryNewExponent = do
e <- entryNew
entrySetWidthChars e 4
l <- labelNew (Just "e")
h <- hBoxNew False spacing
boxPackStart h l PackNatural 0
boxPackStart h e PackNatural 0
return (e, h)
frameNewWithContents box t r ws = do
f <- frameNew
frameSetLabel f t
frameSetLabelAlign f (if r then 1 else 0) 0.5
v <- box False spacing
forM_ ws $ boxPackStartDefaults v
set f [ containerChild := v ]
return f
frameNewWithContents' _ _ _ [] = error "frameNewWithContents': []"
frameNewWithContents' box t r (w:ws) = do
f <- frameNew
frameSetLabel f t
frameSetLabelAlign f (if r then 1 else 0) 0.5
v <- box False spacing
boxPackStart v w PackGrow 0
forM_ ws $ \w' -> boxPackStart v w' PackNatural 0
set f [ containerChild := v ]
return f
dStatus' <- statusDialogNew
b01@bHome' <- buttonNewWithLabel "Home"
b02@bLoad' <- buttonNewWithLabel "Load"
b03@bSave' <- buttonNewWithLabel "Save"
b04@bStop' <- buttonNewWithLabel "Stop"
b7@bAddressToCoordinates' <- buttonNewWithLabel "Go"
b8@bPeriodScan' <- buttonNewWithLabel "Scan"
b9@bPeriodScanPlus' <- buttonNewWithLabel "Scan+"
(eAddress', fa1) <- entryNewWithMnemonic "_Address"
(eRealM', fc1m) <- entryNewWithMnemonic "_Real"
(eRealE', fc1e) <- entryNewExponent
(eImagM', fc2m) <- entryNewWithMnemonic "_Imag"
(eImagE', fc2e) <- entryNewExponent
(eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"
(eSizeE', fc3e) <- entryNewExponent
(eRota', fvR) <- entryNewWithMnemonic' "R_otation" 15
(eWidth', fvW) <- entryNewWithMnemonic' "_Width" 5
(eHeight', fvH) <- entryNewWithMnemonic' "_Height" 5
(eSamples', fvS) <- entryNewWithMnemonic' "_Samples" 3
cInterior' <- colorButtonNewWithColor red
cBorder' <- colorButtonNewWithColor black
cExterior' <- colorButtonNewWithColor white
fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b8, b9]
fa <- frameNewWithContents' hBoxNew "Angled Internal Address" True [toWidget fa1, toWidget b7]
fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior']
fv <- frameNewWithContents hBoxNew "Viewport" True [fvR, fvW, fvH, fvS]
let packMantissaExponent m e = do
h <- hBoxNew False spacing
boxPackStartDefaults h m
boxPackStart h e PackNatural 0
return h
fc1 <- packMantissaExponent fc1m fc1e
fc2 <- packMantissaExponent fc2m fc2e
fc3 <- packMantissaExponent fc3m fc3e
fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3]
v <- vBoxNew False spacing
mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, fa, fh]
h <- hBoxNew False spacing
boxPackStart h fb PackNatural 0
boxPackStartDefaults h v
ww <- windowNew
set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]
containerAdd ww h
mg <- aDoLoad stateFile
gR <- newIORef $ case mg of
Nothing -> initialGruff
Just g -> g
let g0 = GruffGUI
{ dStatus = dStatus'
, bHome = bHome'
, bLoad = bLoad'
, bSave = bSave'
, bStop = bStop'
, bAddressToCoordinates = bAddressToCoordinates'
, bPeriodScan = bPeriodScan'
, bPeriodScanPlus = bPeriodScanPlus'
, eAddress = eAddress'
, eRealM = eRealM'
, eRealE = eRealE'
, eImagM = eImagM'
, eImagE = eImagE'
, eSizeM = eSizeM'
, eSizeE = eSizeE'
, eRota = eRota'
, eWidth = eWidth'
, eHeight = eHeight'
, eSamples = eSamples'
, cInterior = cInterior'
, cBorder = cBorder'
, cExterior = cExterior'
, wMain = ww
, wImage = iw
}
but b a = do
_ <- b g0 `onClicked` wrapA g0 gR a
return ()
butI b a = do
_ <- b g0 `onClicked` (wrapA g0 gR a >> upI)
return ()
butJ b a = do
_ <- b g0 `onClicked` (wrapA' g0 gR a upI)
return ()
butO b a = do
_ <- b g0 `onClicked` a
return ()
ent e a = do
_ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)
return ()
entI e a = do
_ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
return ()
entI' e a = do
_ <- e g0 `onEntryActivate` (do
entryGetText (e g0) >>= wrapE g0 gR a
g <- readIORef gR
browserResize browser (width (gWindow g)) (height (gWindow g)) (supersamples (gWindow g))
upI)
return ()
colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do
_ <- c g0 `onColorSet` (do
ci <- colorButtonGetColor (cbi g0)
cb <- colorButtonGetColor (cbb g0)
ce <- colorButtonGetColor (cbe g0)
_ <- a ci cb ce gR
upI)
return ()
entME m e a = do
let a' = do
ms <- entryGetText (m g0)
es <- entryGetText (e g0)
let s = ms ++ if null es then "" else "e" ++ es
wrapE g0 gR a s
upI
_ <- m g0 `onEntryActivate` a'
_ <- e g0 `onEntryActivate` a'
return ()
upI = do
g <- readIORef gR
browserRender browser Image
{ imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)
, imageLocation = Location
{ center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))
, radius = fromMaybe 0 (gSize g)
}
, imageViewport = (gViewport g){ orient = fromMaybe 0 (gRota g) }
, imageWindow = gWindow g
} (return ()) (return ())
postRedisplay gl'
aUpdate (re :+ im) z = do
atomicModifyIORef gR $ \g ->
( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )
g <- readIORef gR
uReal g0 g
uImag g0 g
uSize g0 g
uRota g0 g
upI
aReshape w' h' = do
atomicModifyIORef gR $ \g ->
( g { gWindow = (gWindow g){ width = w', height = h' }
, gViewport = (gViewport g){ aspect = fromIntegral w' / fromIntegral h' }
}
, () )
g <- readIORef gR
uEverything g0 g
upI
butI bHome aHome
butI bLoad aLoad
but bSave aSave
butO bStop (browserAbort browser)
butJ bAddressToCoordinates aAddressToCoordinates
butJ bPeriodScan (aPeriodScan False)
butJ bPeriodScanPlus (aPeriodScan True)
ent eAddress aAddress
entME eRealM eRealE aReal
entME eImagM eImagE aImag
entME eSizeM eSizeE aSize
entI eRota aRota
entI' eWidth aWidth
entI' eHeight aHeight
entI' eSamples aSamples
colI cInterior cBorder cExterior aColours
let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
browserSetExitCallback browser aExit'
browserSetMouseCallback browser aUpdate
browserSetReshapeCallback browser aReshape
_ <- ww `onDestroy` aExit'
g <- readIORef gR
uEverything g0 g
upI
refreshGUI g0 g
widgetShowAll iw
widgetShowAll ww
mainGUI
data Gruff = Gruff
{ gAddress :: Maybe AngledInternalAddress
, gIsland :: Maybe AngledInternalAddress
, gChild :: Maybe [Angle]
, gLowerAngle :: Maybe Angle
, gUpperAngle :: Maybe Angle
, gReal :: Maybe R
, gImag :: Maybe R
, gSize :: Maybe Double
} | Gruff2
{ gAddress :: Maybe AngledInternalAddress
, gReal :: Maybe R
, gImag :: Maybe R
, gSize :: Maybe Double
, gRota :: Maybe Double
, gColours :: (Color, Color, Color)
, gWindow :: Window
, gViewport :: Viewport
}
deriving (Read, Show)
deriving instance Read Color
initialGruff :: Gruff
initialGruff = Gruff2
{ gAddress = parseAngledInternalAddress "1"
, gReal = Just 0
, gImag = Just 0
, gSize = Just 1
, gRota = Just 0
, gColours = (red, black, white)
, gWindow = defWindow
, gViewport = defViewport
}
refreshGUI :: GruffGUI -> Gruff -> IO ()
refreshGUI g0 g = do
can bAddressToCoordinates $ j gAddress
can bPeriodScan $ True
where
can w = widgetSetSensitive (w g0)
j a = isJust (a g)
-- button actions
type A = GruffGUI -> Gruff -> IO Gruff
type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()
wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
wrapA g0 gR a = do
g <- readIORef gR
g' <- a g0 g
writeIORef gR $! g'
refreshGUI g0 g'
wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()
wrapA' g0 gR a upI = do
g <- readIORef gR
a g0 g $ \g' -> postGUISync $ do
writeIORef gR $! g'
upI
refreshGUI g0 g'
aHome :: A
aHome g0 g = do
let g' = initialGruff{ gColours = gColours g, gWindow = gWindow g, gViewport = gViewport g }
uEverything g0 g'
return g'
aDoLoad :: FilePath -> IO (Maybe Gruff)
aDoLoad ff = (do
gr <- safeRead `fmap` readFile ff
return $ case gr of
Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white) defWindow defViewport)
g -> g
) `catchIO` const (return Nothing)
aLoad :: A
aLoad g0 g = do
fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
widgetShow fc
r <- dialogRun fc
g' <- case r of
ResponseAccept -> do
mf <- fileChooserGetFilename fc
case mf of
Nothing -> return g
Just f -> do
mg <- aDoLoad f
case mg of
Nothing -> return g
Just g' -> uEverything g0 g' >> return g'
_ -> return g
widgetDestroy fc
return g'
aDoSave :: FilePath -> Gruff -> IO ()
aDoSave f g = writeFile f (show g) `catchIO` const (return ())
aSave :: A
aSave g0 g = do
fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
widgetShow fc
r <- dialogRun fc
case r of
ResponseAccept -> do
mf <- fileChooserGetFilename fc
case mf of
Nothing -> return ()
Just f -> aDoSave f g
_ -> return ()
widgetDestroy fc
return g
aPeriodScan :: Bool -> A'
aPeriodScan plus g0 g gn = do
statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of
Nothing -> progress "nothing to do" >> gn g
Just (re, im, r) -> do
forM_ (muLocate (re:+im) r) $ \mp -> case mp of
MuScanTodo -> progress "Scanning for period..."
MuScan -> progress "Scanning for period..."
MuScanDone p -> progress$"Scanning for period... " ++ show p
MuNucleusTodo' -> progress "Computing nucleus..."
MuNucleus' i -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i
MuNucleusDone' _ -> progress "Computing nucleus... done"
MuBondTodo' -> progress "Computing bond..."
MuBond' i -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i
MuBondDone' _ -> progress "Computing bond... done"
MuSuccess'' mu -> do
let g' = g{ gReal = Just . realPart . muNucleus $ mu
, gImag = Just . imagPart . muNucleus $ mu
, gSize = Just . (* 4) . muSize $ mu
, gRota = Just . subtract (pi/2) . muOrient $ mu
}
progress "Found!"
postGUISync $ do
uReal g0 g'
uImag g0 g'
uSize g0 g'
uRota g0 g'
if plus
then
forM_ (muToAddress mu) $ \mp' -> case mp' of
MuCuspTodo -> progress "Computing cusp..."
MuCuspDone _ -> progress "Computing cusp... done"
MuDwellTodo -> progress "Computing dwell..."
MuDwell i -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i
MuDwellDone _ -> progress "Computing dwell... done"
MuRayOutTodo -> progress "Tracing rays..."
MuRayOut i -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"
MuRayOutDone _ -> progress "Tracing rays... done"
MuExternalTodo -> progress "Computing angle..."
MuExternalDone _ -> progress "Computing angle... done"
MuAddressTodo -> progress "Finding address..."
MuSuccess' a -> do
let g'' = g'{ gAddress = Just a }
progress "Complete!"
postGUISync $ do
uAddress g0 g''
gn g''
MuFailed' -> progress "Failed!" >> gn g'
else
gn g'
MuFailed'' -> progress "Failed!" >> gn g
aAddressToCoordinates :: A'
aAddressToCoordinates g0 g gn = do
statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of
Nothing -> progress "nothing to do" >> gn g
Just addr -> do
forM_ (muFromAddress addr) $ \mp -> do
case mp of
MuSplitTodo -> progress "Splitting address..."
MuSplitDone _ _ -> progress "Splitting address... done"
MuAnglesTodo -> progress "Computing angles..."
MuAnglesDone _ _ -> progress "Computing angles... done"
MuRayTodo -> progress "Tracing rays..."
MuRay n -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n
MuRayDone _ -> progress "Tracing rays... done"
MuNucleusTodo -> progress "Computing nucleus..."
MuNucleus n -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n
MuNucleusDone _ -> progress "Computing nucleus... done"
MuBondTodo -> progress "Computing bond..."
MuBond n -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n
MuBondDone _ -> progress "Computing bond... done"
MuSuccess mu -> do
let g' = g{ gReal = Just . realPart . muNucleus $ mu
, gImag = Just . imagPart . muNucleus $ mu
, gSize = Just . (* 4) . muSize $ mu
, gRota = Just . subtract (pi/2) . muOrient $ mu
}
progress "Done!"
postGUISync $ do
uReal g0 g'
uImag g0 g'
uSize g0 g'
uRota g0 g'
gn g'
MuFailed -> progress "Failed!" >> gn g
-- entry update
type U = GruffGUI -> Gruff -> IO ()
uEverything, uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))
uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))
uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))
uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))
uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))
uColours g0 g = do
let (ci, cb, ce) = gColours g
colorButtonSetColor (cInterior g0) ci
colorButtonSetColor (cBorder g0) cb
colorButtonSetColor (cExterior g0) ce
uWidth g0 g = entrySetText (eWidth g0) (show . width . gWindow $ g)
uHeight g0 g = entrySetText (eHeight g0) (show . height . gWindow $ g)
uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . gWindow $ g)
uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
uMantissaExponent m e s = do
let (ms, me) = break (== 'e') s
entrySetText m ms
entrySetText e (drop 1 me)
-- entry actions
type E = Gruff -> String -> Gruff
wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
wrapE g0 gR e s = do
g <- readIORef gR
let g' = e g s
writeIORef gR $! g'
refreshGUI g0 g'
aAddress, aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
aAddress g s = g{ gAddress = parseAngledInternalAddress s }
aReal g s = g{ gReal = safeRead s }
aImag g s = g{ gImag = safeRead s }
aSize g s = g{ gSize = safeRead s }
aRota g s = g{ gRota = safeRead s }
aWidth g s = case safeRead s of
Nothing -> g
Just r -> g{ gWindow = (gWindow g){ width = r } }
aHeight g s = case safeRead s of
Nothing -> g
Just r -> g{ gWindow = (gWindow g){ height = r } }
aSamples g s = case safeRead s of
Nothing -> g
Just r -> g{ gWindow = (gWindow g){ supersamples = r } }
aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())
minSize :: Size
minSize = Size 160 100
red, black, white :: Color
red = Color 65535 0 0
black = Color 0 0 0
white = Color 65535 65535 65535
fromColor :: Color -> Colour
fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)