retroclash-sim (empty) → 0.1.0
raw patch · 6 files changed
+387/−0 lines, 6 filesdep +arraydep +arrowsdep +base
Dependencies added: array, arrows, base, clash-ghc, clash-lib, clash-prelude, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, lens, mtl, retroclash-lib, sdl2, text, transformers
Files
- LICENSE +21/−0
- retroclash-sim.cabal +89/−0
- src/RetroClash/Sim/IO.hs +37/−0
- src/RetroClash/Sim/SDL.hs +138/−0
- src/RetroClash/Sim/VGA.hs +77/−0
- src/RetroClash/Sim/VGASDL.hs +25/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Gergő Érdi (http://gergo.erdi.hu/)++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.
+ retroclash-sim.cabal view
@@ -0,0 +1,89 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4978ab887c6a454f99ca9aaf7e15110a6b7360da275ae11d0437b9b59f1558e0++name: retroclash-sim+version: 0.1.0+synopsis: High-level simulators from the book "Retrocomputing with Clash"+description: A library of functionality useful when simulating retro-computers:+ .+ * Interactive Clash simulation in IO+ .+ * SDL-based framework for graphics simulation+ .+ * VGA signal interpreter+ .+category: Hardware, Graphics+homepage: https://unsafePerform.IO/retroclash/+bug-reports: https://github.com/gergoerdi/retroclash-sim/issues+author: Gergő Érdi+maintainer: gergo@erdi.hu+copyright: 2021 Gergő Érdi+license: MIT+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/gergoerdi/retroclash-sim++library+ exposed-modules:+ RetroClash.Sim.SDL+ RetroClash.Sim.VGA+ RetroClash.Sim.VGASDL+ RetroClash.Sim.IO+ other-modules:+ Paths_retroclash_sim+ hs-source-dirs:+ src+ default-extensions:+ BinaryLiterals+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveGeneric+ DeriveLift+ DerivingStrategies+ ExplicitForAll+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ KindSignatures+ MagicHash+ MonoLocalBinds+ NoImplicitPrelude+ NoMonomorphismRestriction+ NoStarIsType+ NoStrictData+ NoStrict+ QuasiQuotes+ ScopedTypeVariables+ TemplateHaskellQuotes+ TemplateHaskell+ TypeApplications+ TypeFamilies+ TypeInType+ TypeOperators+ ghc-options: -fexpose-all-unfoldings -fno-worker-wrapper -fplugin GHC.TypeLits.KnownNat.Solver -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.Extra.Solver+ build-depends:+ array+ , arrows+ , base >=4.14 && <5+ , clash-ghc >=1.4.2 && <1.5+ , clash-lib >=1.4.2 && <1.5+ , clash-prelude >=1.4.2 && <1.5+ , ghc-typelits-extra+ , ghc-typelits-knownnat+ , ghc-typelits-natnormalise+ , lens+ , mtl+ , retroclash-lib ==0.1.*+ , sdl2+ , text+ , transformers+ default-language: Haskell2010
+ src/RetroClash/Sim/IO.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RankNTypes #-}+module RetroClash.Sim.IO+ ( simulateIO+ , simulateIO_+ ) where++import Clash.Prelude+import Control.Concurrent+import Control.Monad.IO.Class+import Control.Monad (void)+import Control.Arrow.Transformer.Automaton++simulateIO+ :: (KnownDomain dom, MonadIO m, NFDataX i, NFDataX o)+ => (HiddenClockResetEnable dom => Signal dom i -> Signal dom o)+ -> i+ -> IO ((o -> m (i, a)) -> m a)+simulateIO circuit input0 = do+ let Automaton step = signalAutomaton circuit+ ref <- newMVar $ step input0+ return $ \world -> do+ (out, Automaton step) <- liftIO $ takeMVar ref+ (input, result) <- world out+ liftIO $ putMVar ref $ step input+ return result++simulateIO_+ :: (KnownDomain dom, MonadIO m, NFDataX i, NFDataX o)+ => (HiddenClockResetEnable dom => Signal dom i -> Signal dom o)+ -> i+ -> IO ((o -> m i) -> m ())+simulateIO_ circuit input0 = do+ sim <- simulateIO circuit input0+ return $ \world -> do+ void $ sim $ \output -> do+ input <- world output+ return (input, ())
+ src/RetroClash/Sim/SDL.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections, NumericUnderscores #-}+module RetroClash.Sim.SDL+ ( VideoParams(..)+ , withMainWindow+ , module SDL.Input.Keyboard.Codes++ , Rasterizer+ , rasterizePattern++ , BufferArray(..)+ , newBufferArray+ , rasterizeBuffer++ , Color+ , packColor+ ) where++import Prelude+import Clash.Prelude hiding (lift)+import RetroClash.Utils++import SDL hiding (get)+import SDL.Input.Keyboard.Codes+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import Data.Word+import Control.Concurrent (threadDelay)+import Data.Text (Text)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Array.IO+import Data.IORef+import Text.Printf++newtype Rasterizer (w :: Nat) (h :: Nat) = Rasterizer{ runRasterizer :: Ptr () -> Int -> IO () }++data VideoParams = MkVideoParams+ { windowTitle :: Text+ , screenScale :: CInt+ , screenRefreshRate :: Int+ , reportFPS :: Bool+ }++withMainWindow+ :: forall w h m. (KnownNat w, KnownNat h, MonadIO m)+ => VideoParams+ -> ([Event] -> (Scancode -> Bool) -> MaybeT m (Rasterizer w h))+ -> m ()+withMainWindow MkVideoParams{..} runFrame = do+ initializeAll+ window <- createWindow windowTitle defaultWindow+ windowSize window $= fmap (screenScale *) screenSize++ withTexture <- setupTexture window+ let render rasterizer = withTexture $ \ptr rowstride ->+ liftIO $ runRasterizer rasterizer ptr rowstride++ runMaybeT $ atFrameRate reportFPS screenRefreshRate $ do+ events <- pollEvents+ keys <- getKeyboardState+ let windowClosed = any isWindowCloseEvent events+ guard $ not windowClosed+ rasterizer <- runFrame events keys+ render rasterizer+ destroyWindow window+ where+ screenSize = V2 (snatToNum (SNat @w)) (snatToNum (SNat @h))++ setupTexture window = do+ renderer <- createRenderer window (-1) defaultRenderer+ texture <- createTexture renderer RGB888 TextureAccessStreaming screenSize++ return $ \drawToTexture -> do+ (ptr, stride) <- lockTexture texture Nothing+ drawToTexture ptr (fromIntegral stride)+ unlockTexture texture+ SDL.copy renderer texture Nothing Nothing+ present renderer++ isWindowCloseEvent ev = case eventPayload ev of+ WindowClosedEvent{} -> True+ _ -> False++atFrameRate :: (MonadIO m) => Bool -> Int -> m a -> m b+atFrameRate reportFPS frameRate act = do+ before0 <- ticks+ go before0 1+ where+ go before0 i = do+ before <- ticks+ act+ after <- ticks+ waitFrame frameRate before after+ if i < frameRate then go before0 (i + 1) else do+ when reportFPS $ do+ let elapsed = after - before0+ liftIO $ printf "%d frames at %d ms, %.2f fps\n" frameRate elapsed (fps elapsed)+ before0 <- ticks+ go before0 1++ fps elapsed = (fromIntegral frameRate * 1000) / fromIntegral elapsed :: Double++waitFrame :: (MonadIO m) => Int -> Word32 -> Word32 -> m ()+waitFrame frameRate before after = when (slack > 0) $ liftIO $ threadDelay slack+ where+ frameTime = 1_000_000 `div` frameRate+ elapsed = fromIntegral $ 1000 * (after - before)+ slack = frameTime - elapsed++type Color = (Word8, Word8, Word8)++{-# INLINE packColor #-}+packColor :: Color -> Word32+packColor (r, g, b) =+ fromIntegral r `shiftL` 16 .|.+ fromIntegral g `shiftL` 8 .|.+ fromIntegral b `shiftL` 0++rasterizePattern :: (KnownNat w, KnownNat h) => (Index w -> Index h -> Color) -> Rasterizer w h+rasterizePattern draw = Rasterizer $ \ptr rowstride -> do+ forM_ [minBound..maxBound] $ \y -> do+ let rowPtr = plusPtr ptr $ fromIntegral y * rowstride+ forM_ [minBound .. maxBound] $ \x -> do+ pokeElemOff rowPtr (fromIntegral x) (packColor $ draw x y)++newtype BufferArray (w :: Nat) (h :: Nat) = BufferArray{ getArray :: IOUArray (Index w, Index h) Word32 }++newBufferArray :: forall w h. (KnownNat w, KnownNat h) => IO (BufferArray w h)+newBufferArray = BufferArray <$> newArray ((minBound, minBound), (maxBound, maxBound)) 0++rasterizeBuffer :: forall w h. (KnownNat w, KnownNat h) => BufferArray w h -> Rasterizer w h+rasterizeBuffer (BufferArray arr) = Rasterizer $ \ptr rowstride -> do+ forM_ [minBound..maxBound] $ \y -> do+ let rowPtr = plusPtr ptr $ fromIntegral y * rowstride+ forM_ [minBound..maxBound] $ \x -> do+ pokeElemOff rowPtr (fromIntegral x) =<< readArray arr (x, y)
+ src/RetroClash/Sim/VGA.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE NumericUnderscores, RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+module RetroClash.Sim.VGA+ ( vgaSink+ , initSink+ , SinkState+ ) where++import RetroClash.Utils+import RetroClash.VGA++import Control.Monad.State+import Data.Foldable (for_)+import Control.Lens hiding (Index)+import Clash.Prelude hiding (lift)+import Data.Proxy++import Debug.Trace++vgaRetrace :: VGATiming visible -> (Int, Bit)+vgaRetrace VGATiming{..} = (snatToNum pulseWidth + snatToNum postWidth - 1, toActiveDyn polarity True)++data SinkState n+ = Visible (Index n)+ | WaitSync Bool+ | Retrace Int+ deriving (Show)++{-# INLINE vgaSink #-}+vgaSink+ :: forall w h rgb m ps. (KnownNat w, KnownNat h, MonadState (SinkState w, SinkState h) m)+ => VGATimings ps w h+ -> (Index w -> Index h -> rgb -> m ())+ -> (Bit, Bit, rgb)+ -> m Bool+vgaSink VGATimings{..} paint (hsync0, vsync0, color) = do+ (x, endLine) <- stateZoom _1 $ direction w horizRetrace hsync+ (y, endFrame) <- stateZoomIf endLine _2 $ direction h vertRetrace vsync+ for_ (liftA2 (,) x y) $ \(x, y) -> paint x y color+ return $ endLine && endFrame+ where+ (horizRetrace, hsyncTarget) = vgaRetrace vgaHorizTiming+ (vertRetrace, vsyncTarget) = vgaRetrace vgaVertTiming++ vsync = vsync0 == vsyncTarget+ hsync = hsync0 == hsyncTarget++ w = snatToNum (SNat @w)+ h = snatToNum (SNat @h)++ direction vis retrace sync s = case s of+ Retrace n -> ((Nothing, False), s')+ where+ n' = n + 1+ s' = if n' == retrace then Visible 0 else Retrace n'+ Visible i -> ((Just i, False), s')+ where+ s' = maybe (WaitSync sync) Visible $ succIdx i+ WaitSync prevSync -> ((Nothing, end), s')+ where+ end = not prevSync && sync+ s' = if end then Retrace 0 else WaitSync sync++initSink :: (SinkState w, SinkState h)+initSink = (WaitSync False, WaitSync False)++{-# INLINE stateZoom #-}+stateZoom :: (MonadState s0 m) => Lens' s0 s -> (s -> (a, s)) -> m a+stateZoom = stateZoomIf True++{-# INLINE stateZoomIf #-}+stateZoomIf :: (MonadState s0 m) => Bool -> Lens' s0 s -> (s -> (a, s)) -> m a+stateZoomIf update l f = state $ \s0 ->+ let s = view l s0+ (x, s') = f s+ s0' = s0 & l .~ s'+ in (x, if update then s0' else s0)
+ src/RetroClash/Sim/VGASDL.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NumericUnderscores, RecordWildCards #-}+module RetroClash.Sim.VGASDL+ ( vgaSinkBuf+ ) where++import Clash.Prelude+import RetroClash.Utils+import RetroClash.VGA+import RetroClash.Sim.VGA+import RetroClash.Sim.SDL++import Control.Monad.State+import Data.Word+import Data.Array.IO++{-# INLINE vgaSinkBuf #-}+vgaSinkBuf+ :: (KnownNat w, KnownNat h, MonadIO m, MonadState (SinkState w, SinkState h) m)+ => VGATimings ps w h+ -> BufferArray w h+ -> (Bit, Bit, Color)+ -> m Bool+vgaSinkBuf vgaMode (BufferArray arr) = vgaSink vgaMode writeBuf+ where+ writeBuf x y rgb = liftIO $ writeArray arr (x, y) $ packColor rgb