module HFoil.Repl
( run
) where
import Control.Concurrent ( forkIO )
import Control.Concurrent.MVar ( newMVar, readMVar, swapMVar )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.State.Strict ( StateT, evalStateT, get, modify )
import Data.List ( isPrefixOf )
import Linear ( Quaternion(..), V3(..) )
import System.Console.Haskeline ( InputT, runInputT, defaultSettings, getInputLine, outputStrLn, setComplete )
import System.Console.Haskeline.Completion ( CompletionFunc, Completion, completeWord, simpleCompletion )
import Text.Read ( readMaybe )
import Vis
import HFoil.Foil
import HFoil.Naca4
import HFoil.Drawing
import HFoil.Flow
nPanels :: Int
nPanels = 200
data Config = Config { confForces :: Bool
, confKuttas :: Bool
, confNormals :: Bool
}
defaultConfig :: Config
defaultConfig = Config { confForces = False
, confKuttas = False
, confNormals = False
}
data Mode = TopMode | FoilMode
foilCommands :: [(String, String)]
foilCommands =
[ ("alfa", "alfa [#]")
, ("forces", "forces")
, ("kuttas", "kuttas")
, ("normals", "normals")
, ("help", "help")
]
topCommands :: [(String, String)]
topCommands =
[ ("naca", "naca xxxx")
, ("load", "load [filename]")
, ("uiuc", "uiuc [foil name]")
]
topHelp :: InputT (StateT Mode IO) ()
topHelp = mapM_ (outputStrLn . snd) topCommands
foilHelp :: InputT (StateT Mode IO) ()
foilHelp = mapM_ (outputStrLn . snd) foilCommands
comp :: CompletionFunc (StateT Mode IO)
comp = completeWord Nothing " \t" searchFunc
where
searchFunc :: String -> (StateT Mode IO) [Completion]
searchFunc str = do
mode <- get
let wordList = case mode of
TopMode -> map fst topCommands
FoilMode -> map fst foilCommands
return $ map simpleCompletion $ filter (str `isPrefixOf`) wordList
run :: IO ()
run = do
mpics <- newMVar $ []
putStrLn "Welcome to hfoil\n"
let go :: InputT (StateT Mode IO) ()
go = topLoop (\pics -> swapMVar mpics pics >>= (\_ -> return ())) defaultConfig
settings = setComplete comp defaultSettings
_ <- forkIO $ flip evalStateT TopMode $ runInputT settings go
let toScreen xs =
RotQuat (Quaternion 0 (V3 1 0 0))
$ Trans (V3 (0.5) 0 0)
$ VisObjects xs
cam0 =
Camera0
{ phi0 = 90
, theta0 = 90
, rho0 = 2
}
animateIO
(defaultOpts {optWindowName = "hfoil", optInitialCamera = Just cam0})
(\_ -> fmap toScreen (readMVar mpics))
data FoilState =
FoilState
{ fsFlowSol :: Maybe (FlowSol Double)
, fsConf :: Config
, fsFoil :: Foil Double
}
drawPicture :: MonadIO m => ([VisObject Double] -> IO ()) -> StateT FoilState m ()
drawPicture draw = do
fs <- get
let conf = fsConf fs
foil = fsFoil fs
normals = case confNormals conf of
True -> [drawNormals foil]
False -> []
case fsFlowSol fs of
Nothing -> liftIO $ draw (drawFoil foil: normals)
Just flow -> do
let forces = case (confForces conf) of
True -> [drawForces flow]
False -> []
kuttas = case (confKuttas conf) of
True -> [drawKuttas flow]
False -> []
liftIO $ draw $ forces++kuttas++normals++[drawSolution flow]
strip :: String -> String
strip = rstrip . lstrip
where
lstrip (' ':xs) = lstrip xs
lstrip x = x
rstrip = reverse . lstrip . reverse
foilLoop :: ([VisObject Double] -> IO ()) -> StateT FoilState (InputT (StateT Mode IO)) ()
foilLoop draw = do
lift (lift (modify (const FoilMode)))
fs <- get
let foil@(Foil _ name) = fsFoil fs
conf = fsConf fs
drawPicture draw
minput <- lift $ getInputLine $ "\ESC[1;32m\STXhfoil."++name++">> \ESC[0m\STX"
case fmap strip minput of
Nothing -> return ()
Just "quit" -> do lift $ outputStrLn "not-gloss won't let you quit :(\ntry ctrl-c or hit ESC in drawing window"
foilLoop draw
Just ('a':'l':'f':'a':' ':alphaDeg') -> do
case readMaybe alphaDeg' of
Nothing -> do lift $ outputStrLn $ "parse fail on " ++ show alphaDeg'
foilLoop draw
Just alphaDeg -> do let flow :: FlowSol Double
flow = solveFlow foil (pi/180*alphaDeg)
modify (\fs' -> fs' {fsFlowSol = Just flow})
foilLoop draw
Just "forces" -> do
let newConf = conf {confForces = not (confForces conf)}
lift $ outputStrLn $ "force drawing set to "++ show (not (confForces conf))
modify (\fs' -> fs' {fsConf = newConf})
foilLoop draw
Just "kuttas" -> do
let newConf = conf {confKuttas = not (confKuttas conf)}
lift $ outputStrLn $ "kutta drawing set to "++ show (not (confKuttas conf))
modify (\fs' -> fs' {fsConf = newConf})
foilLoop draw
Just "normals" -> do
let newConf = conf {confNormals = not (confNormals conf)}
lift $ outputStrLn $ "normals drawing set to "++ show (not (confNormals conf))
modify (\fs' -> fs' {fsConf = newConf})
foilLoop draw
Just "help" -> lift foilHelp >> foilLoop draw
Just "h" -> lift foilHelp >> foilLoop draw
Just "?" -> lift foilHelp >> foilLoop draw
Just "" -> return ()
Just input -> do lift $ outputStrLn $ "unrecognized command \"" ++ input ++ "\""
foilLoop draw
topLoop :: ([VisObject Double] -> IO ()) -> Config -> InputT (StateT Mode IO) ()
topLoop draw conf = do
lift (modify (const TopMode))
minput <- getInputLine "\ESC[1;32m\STXhfoil>> \ESC[0m\STX"
case minput of
Nothing -> return ()
Just msg -> do runTop draw conf msg
topLoop draw conf
runTop :: ([VisObject Double] -> IO ()) -> Config -> String -> InputT (StateT Mode IO) ()
runTop draw conf msg = case strip msg of
"quit" -> outputStrLn "not-gloss won't let you quit :(\ntry ctrl-c or hit ESC in drawing window"
('n':'a':'c':'a':' ':spec) -> do
case naca4 spec :: Maybe (Naca4 Double) of
Nothing -> outputStrLn "not a valid naca4"
Just n4 -> runFoil draw conf (panelizeNaca4 n4 nPanels)
('l':'o':'a':'d':' ':name) -> do
mfoil <- liftIO (loadFoil name)
case mfoil of Left errMsg -> outputStrLn errMsg
Right foil -> do runFoil draw conf foil
('u':'i':'u':'c':' ':name) -> do
efoil <- liftIO (getUIUCFoil name)
case efoil of Left errMsg -> outputStrLn errMsg
Right foil -> do let Foil els _ = foil
outputStrLn $ "got " ++ show (length els) ++ " elements"
runFoil draw conf foil
"help" -> topHelp
"h" -> topHelp
"?" -> topHelp
"" -> return ()
other -> outputStrLn $ "unrecognized command \"" ++ other ++ "\""
runFoil :: ([VisObject Double] -> IO ()) -> Config -> Foil Double -> InputT (StateT Mode IO) ()
runFoil draw conf foil = do
let state0 =
FoilState
{ fsFlowSol = Nothing
, fsConf = conf
, fsFoil = foil
}
let go :: StateT FoilState (InputT (StateT Mode IO)) ()
go = foilLoop draw
flip evalStateT state0 go