├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app ├── Main.hs ├── Tile.hs └── UI.hs ├── dist-newstyle └── sdist │ └── timetravel-0.1.0.0.tar.gz ├── img ├── simple.png ├── sol1.gif ├── sol2.gif ├── start.png └── whole.gif ├── src └── TimeLoop │ ├── Search.hs │ ├── Types.hs │ └── Walker.hs ├── test └── Spec.hs └── timetravel.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for timetravel 2 | 3 | ## V1.0 4 | First release. 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # TimeLoop 2 | 3 | This is a demonstrator for studying time travel in a simple setting. 4 | The application will generate and display all the possible trajectories in a universe, in presence of time travel. 5 | See this [series of blog posts](https://www.corentindupont.info/blog/posts/Cosmology/2022-04-04-TimeTravel2.html) for more explainations. 6 | 7 | Install 8 | ======= 9 | 10 | [Download](https://github.com/cdupont/Timeloop/releases/tag/v1.0) one of the binary files from the release, unzip and run it. 11 | 12 | Alternatively, you can clone this repo. Then [Install Haskell](https://www.haskell.org/ghcup/) and run: 13 | ``` 14 | cabal install 15 | ``` 16 | Launch the demo: 17 | ``` 18 | timetravel 19 | ``` 20 | 21 | 22 | How to play 23 | =========== 24 | 25 | You start by setting up the universe, and then run the simulation. 26 | In the picture bellow, there is an "emitter" arrow on the left and two time portals: an entry portal, and an exit portal. 27 | The emitter will emit a "walker", here at time step 0. 28 | The walkers always walk straight, except when they collides with another walker. 29 | When a walker collide with another walker, they always turn right (as a rule). 30 | If the walker enters the entry portal at the right time, it will walk out of the exit portal at the mentioned time. 31 | 32 | ![start](img/start.png) 33 | 34 | You can move the various elements of the universe (emitters and portals), setup their activation time, and add more of them (see the instructions). 35 | **When you are ready, hit Enter.** 36 | 37 | ![whole](img/whole.gif) 38 | 39 | In this universe setup, there are **2 possible trajectories** for the walker: 40 | The first solution is simple: he just goes straight. At step 6, he will walk over the exit portal (this has no effects). 41 | 42 | ![sol1](img/sol1.gif) 43 | 44 | However, there is another solution! 45 | At the start of the simulation (highlighted as step 0), another walker appears in the exit portal: it's you from the future! Both goes straight some steps, meeting in the middle. Then, as per the rule on collisions, both turn right. The initial walker enters the portal at step 6, thus closing the loop. The second walker continues toward the top. 46 | 47 | ![sol2](img/sol2.gif) 48 | 49 | You can play around with different universe setups, and generate interresting configurations such as paradoxes, "Djinns" and more. 50 | You can load examples using the number keys. 51 | Have fun! 52 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ApplicativeDo #-} 6 | {-# LANGUAGE OverloadedRecordDot #-} 7 | 8 | module Main where 9 | 10 | import Options.Applicative.Simple 11 | import Brick (customMain, hBox) 12 | import UI 13 | import TimeLoop.Types 14 | import TimeLoop.Search 15 | import Brick.BChan 16 | import qualified Graphics.Vty as V 17 | import qualified Graphics.Vty.CrossPlatform as VCP 18 | import Control.Concurrent (threadDelay, forkIO) 19 | import Control.Monad (void, forever) 20 | 21 | main :: IO () 22 | main = do 23 | --((i,o),()) <- simpleOptions "ver" 24 | -- "header" 25 | -- "desc" 26 | -- options 27 | -- empty 28 | --let (pos1 :: PTD) = readPos i 29 | --let (pos2 :: PTD) = readPos o 30 | --let univ = [Portal pos1 pos2] 31 | chan <- newBChan 10 32 | void . forkIO $ forever $ do 33 | writeBChan chan Tick 34 | threadDelay 100000 35 | putStrLn "Loading" 36 | let initState = UI univ2 (Just (SelItem EntryPortal 0)) 0 (Config False False) 37 | let buildVty = VCP.mkVty V.defaultConfig 38 | initialVty <- buildVty 39 | a <- customMain initialVty buildVty (Just chan) app initState 40 | putStrLn $ show a.initUniv 41 | putStrLn "Goodbye" 42 | 43 | 44 | options :: Parser (String, String) 45 | options = do 46 | i <- (strOption (short 'i') :: Parser String) 47 | o <- (strOption (short 'o') :: Parser String) 48 | return (i, o) 49 | 50 | 51 | -------------------------------------------------------------------------------- /app/Tile.hs: -------------------------------------------------------------------------------- 1 | 2 | module Tile where 3 | 4 | import TimeLoop.Types 5 | import TimeLoop.Walker 6 | import Text.Printf 7 | 8 | tilePortal :: Bool -> Dir -> Time -> String 9 | tilePortal in_ dir time = 10 | "┌─" ++ n ++ "─┐\n" ++ 11 | w ++ c ++ e ++ "\n" ++ 12 | "└─" ++ s ++ "─┘" where 13 | w = if side == W then showArr dir else "│ " 14 | e = if side == E then showArr dir else " │" 15 | n = if side == N then showArr dir else "──" 16 | s = if side == S then showArr dir else "──" 17 | c = printf "%2d" time 18 | side = if in_ then turnRel Back dir else dir 19 | 20 | tileWalker :: Dir -> Time -> String 21 | tileWalker = tileArr showArr 22 | 23 | tileEntry :: Dir -> Time -> String 24 | tileEntry = tileArr showFromBarArr 25 | 26 | tileExit :: Dir -> Time -> String 27 | tileExit = tileArr showToBarArr 28 | 29 | tileArr :: (Dir -> String) -> Dir -> Time -> String 30 | tileArr showArr dir time = 31 | " " ++ t ++ "\n" ++ 32 | " " ++ c ++ " \n" ++ 33 | " \n" where 34 | c = showArr dir 35 | t = printf "%2d" time 36 | 37 | tileCollision :: Dir -> Dir -> Time -> String 38 | tileCollision d1 d2 time = 39 | " " ++ n ++ t ++"\n" ++ 40 | w ++ "★ " ++ e ++ "\n" ++ 41 | " " ++ s ++ " " where 42 | w = getArrLoc E (d1, d2) 43 | e = getArrLoc W (d1, d2) 44 | s = getArrLoc N (d1, d2) 45 | n = getArrLoc S (d1, d2) 46 | t = printf "%2d" time 47 | 48 | tileEmpty :: String 49 | tileEmpty = " \n" ++ 50 | " \n" ++ 51 | " " 52 | 53 | showArr :: Dir -> String 54 | showArr N = "↑ " 55 | showArr W = "← " 56 | showArr E = "→ " 57 | showArr S = "↓ " 58 | 59 | showFromBarArr :: Dir -> String 60 | showFromBarArr N = "↥ " 61 | showFromBarArr W = "↤ " 62 | showFromBarArr E = "↦ " 63 | showFromBarArr S = "↧ " 64 | 65 | showToBarArr :: Dir -> String 66 | showToBarArr N = "⤒ " 67 | showToBarArr W = "⇤ " 68 | showToBarArr E = "⇥ " 69 | showToBarArr S = "⤓ " 70 | 71 | 72 | -- Get the collision arrow given your own direction 73 | getArrLoc :: Dir -> (Dir, Dir) -> String 74 | getArrLoc d (d1, d2) | d == d1 = getAngleArr (d, turnRel Right_ d) 75 | getArrLoc d (d1, d2) | d == d2 = getAngleArr (d, turnRel Right_ d) 76 | getArrLoc _ _ = " " 77 | 78 | getAngleArr :: (Dir, Dir) -> String 79 | getAngleArr (N, E) = "↱ " 80 | getAngleArr (N, S) = "↱ " 81 | getAngleArr (N, W) = "↰ " 82 | getAngleArr (S, E) = "↳ " 83 | getAngleArr (S, W) = "↲ " 84 | getAngleArr (S, N) = "↲ " 85 | getAngleArr (E, N) = "⬏ " 86 | getAngleArr (E, S) = "⬎ " 87 | getAngleArr (E, W) = "⬎ " 88 | getAngleArr (W, N) = "⬑ " 89 | getAngleArr (W, E) = "⬑ " 90 | getAngleArr (W, S) = "⬐ " 91 | getAngleArr (_, _) = " " 92 | 93 | -------------------------------------------------------------------------------- /app/UI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | 7 | module UI where 8 | 9 | import Brick 10 | import Brick.Widgets.Table 11 | import Brick.Widgets.Center (hCenter, center) 12 | import Brick.Widgets.Border 13 | import Brick.AttrMap 14 | import TimeLoop.Types 15 | import TimeLoop.Search 16 | import TimeLoop.Walker 17 | import Data.List.Split 18 | import Data.List 19 | import qualified Data.Map as M 20 | import qualified Graphics.Vty as V 21 | import qualified Graphics.Vty.Attributes as VA 22 | import Text.Printf 23 | import Optics 24 | import Optics.Label 25 | import GHC.Generics (Generic) 26 | import Tile 27 | import Control.Monad.IO.Class 28 | 29 | data ItemType = EntryPortal | ExitPortal | Entry | Exit | Walker_ 30 | deriving (Eq, Ord, Show) 31 | 32 | data Item = Item { 33 | itemType :: ItemType, 34 | time :: Time, 35 | dir :: Dir, 36 | sel :: Maybe Bool, 37 | high :: Maybe Bool, 38 | col :: Maybe Int} 39 | deriving (Eq, Ord, Show) 40 | 41 | type ItemMap = M.Map Pos [Item] 42 | 43 | data SelItem = SelItem { 44 | itemType :: ItemType, 45 | itemIndex :: Int} 46 | deriving (Eq, Show) 47 | 48 | type Step = Int 49 | 50 | data UI = UI { 51 | initUniv :: Univ, 52 | selItem :: Maybe SelItem, -- Which item is selected 53 | stepItem :: Step, -- A time step counter 54 | config :: Config} 55 | deriving (Generic) 56 | 57 | data Config = Config { 58 | showSols :: Bool, 59 | showWrongTrajs :: Bool} 60 | deriving (Generic) 61 | 62 | -- | Ticks mark passing of time 63 | data Tick = Tick 64 | 65 | 66 | -- * Main app 67 | 68 | app :: App UI Tick () 69 | app = App 70 | { appDraw = drawUI 71 | , appChooseCursor = neverShowCursor 72 | , appHandleEvent = handleEvent 73 | , appStartEvent = return () 74 | , appAttrMap = theMap 75 | } 76 | 77 | lims :: Limits 78 | lims = ((-1, -3), (7, 3)) 79 | 80 | 81 | -- * UI 82 | 83 | -- Display the whole interface 84 | drawUI :: UI -> [Widget ()] 85 | drawUI (UI u sel st conf)= [center (drawConfigPanel u sel) <+> borderWithLabel (str "Instructions") (padAll 1 $ str help) 86 | <=> (str $ encouragement (showSols conf) (length $ getValidSTBlocks u)) 87 | <=> (if showSols conf then drawSearchPanel u st conf else emptyWidget)] 88 | 89 | -- Display the top panel for configuring the universe. 90 | drawConfigPanel :: Univ -> Maybe SelItem -> Widget () 91 | drawConfigPanel u sel = borderWithLabel (str " Universe setup ") $ drawItemMap (getItemsUniv u sel Nothing) lims 92 | 93 | -- Display the various solutions 94 | drawSearchPanel :: Univ -> Step -> Config -> Widget () 95 | drawSearchPanel u st conf = hBox $ if showWrongTrajs conf then showAllSols else showGoodSols where 96 | showGoodSols = zipWith (\b i -> showSol b (" Solution n." ++ show i ++ " ") True st) (filter isValidBlock $ getAllSTBlocks u) [1..] 97 | showAllSols = map (\b -> showSol b "" (isValidBlock b) st) $ getAllSTBlocks u 98 | 99 | showSol :: STBlock -> String -> Bool -> Step -> Widget () 100 | showSol block msg isGood step = overrideAttr borderAttr (if isGood then borderGood else borderBad) $ drawBlock msg block step 101 | 102 | drawBlock :: String -> STBlock -> Step -> Widget () 103 | drawBlock label block step = borderWithLabel (str label) $ drawItemMap (getItemMap block Nothing (Just step)) lims 104 | 105 | -- Get the various items in a Block as a Map 106 | getItemMap :: STBlock -> Maybe SelItem -> Maybe Step -> ItemMap 107 | getItemMap (STBlock u ws) sel st = M.map (sortBy $ timePrio st) $ M.unionWith (++) (getItemsUniv u sel st) walkers where 108 | walkers = M.fromListWith (++) $ map (\(Walker (PTD p t d)) -> (p, [Item Walker_ t d Nothing (highlighted t st) Nothing])) ws 109 | 110 | -- Get the various items in Univ 111 | getItemsUniv :: Univ -> Maybe SelItem -> Maybe Step -> ItemMap 112 | getItemsUniv (Univ ps es cs) sel st = M.fromListWith (++) (entries ++ exits ++ portalEntries ++ portalExits) where 113 | entries = zipWith (\(Source (PTD p t d)) i -> (p, [Item Entry t d (selected sel Entry i) (highlighted t st) Nothing])) es [0..] 114 | exits = zipWith (\(Sink (PTD p t d)) i -> (p, [Item Exit t d (selected sel Exit i) (highlighted t st) Nothing])) cs [0..] 115 | portalEntries = zipWith (\(Portal (Sink (PTD p t d)) _) i -> (p, [Item EntryPortal t d (selected sel EntryPortal i) (highlighted t st) (Just i)])) ps [0..] 116 | portalExits = zipWith (\(Portal _ (Source (PTD p t d))) i -> (p, [Item ExitPortal t d (selected sel ExitPortal i) (highlighted t st) (Just i)])) ps [0..] 117 | 118 | -- Highlight items that on the current timestep 119 | highlighted t (Just st') = Just $ (st' `div` 10 `mod` maxStep) == t 120 | highlighted _ _ = Nothing 121 | 122 | -- Items selected by the user 123 | selected :: Maybe SelItem -> ItemType -> Int -> Maybe Bool 124 | selected (Just (SelItem it index)) it' index' = Just ( it == it' && index == index') 125 | selected _ _ _ = Nothing 126 | 127 | -- Items that are on the current timestep will be displayed with higher priority. 128 | timePrio (Just st) (Item _ t1 _ _ _ _) _ | t1 == st `div` 10 `mod` maxStep = LT 129 | timePrio (Just st) _ (Item _ t2 _ _ _ _) | t2 == st `div` 10 `mod` maxStep = GT 130 | timePrio _ a b = compare a b 131 | 132 | -- Draws items 133 | drawItemMap :: ItemMap -> Limits -> Widget () 134 | drawItemMap is ((minX, minY), (maxX, maxY)) = vBox $ map row [maxY, maxY-1 .. minY] where 135 | row y = hBox $ map (\x -> drawItems (Pos x y) is) [minX..maxX] 136 | 137 | -- Draw items at a specific position 138 | drawItems :: Pos -> ItemMap -> Widget () 139 | drawItems p is = case M.lookup p is of 140 | Just items -> drawTile items 141 | Nothing -> drawTile [] 142 | 143 | -- draw a single tile 144 | -- Only the first item in the list will be displayed (except for collisions) 145 | drawTile :: [Item] -> Widget () 146 | drawTile [] = str tileEmpty 147 | drawTile ((Item EntryPortal t d sel high pair) : _) = setAttr sel high pair $ str $ tilePortal True d t 148 | drawTile ((Item ExitPortal t d sel high pair) : _) = setAttr sel high pair $ str $ tilePortal False d t 149 | drawTile ((Item Entry t d sel high pair) : _) = setAttr sel high pair $ str $ tileEntry d t 150 | drawTile ((Item Exit t d sel high pair) : _) = setAttr sel high pair $ str $ tileExit d t 151 | drawTile ((Item Walker_ t1 d1 sel high pair) : (Item Walker_ t2 d2 _ _ _) : _) | t1 == t2 = setAttr sel high pair $ str $ tileCollision d1 d2 t1 152 | drawTile ((Item Walker_ t d sel high pair) : _) = setAttr sel high pair $ str $ tileWalker d t 153 | 154 | setAttr :: Maybe Bool -> Maybe Bool -> Maybe Int -> Widget () -> Widget () 155 | setAttr sel high pair = withDefAttr (pairAttr pair) . withDefAttr (selectAttr sel) . withDefAttr (dimAttr high) where 156 | dimAttr (Just False) = dimA 157 | dimAttr _ = mempty 158 | selectAttr (Just True) = selA 159 | selectAttr _ = mempty 160 | pairAttr (Just n) = portalA n 161 | pairAttr _ = mempty 162 | 163 | -- * Events 164 | 165 | handleEvent :: BrickEvent () Tick -> EventM () UI () 166 | handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt 167 | handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt 168 | handleEvent (VtyEvent (V.EvKey V.KRight [])) = modify $ move' E 169 | handleEvent (VtyEvent (V.EvKey V.KLeft [])) = modify $ move' W 170 | handleEvent (VtyEvent (V.EvKey V.KUp [])) = modify $ move' N 171 | handleEvent (VtyEvent (V.EvKey V.KDown [])) = modify $ move' S 172 | handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = modify rotate 173 | handleEvent (VtyEvent (V.EvKey (V.KChar '+') [])) = modify $ changeTime True 174 | handleEvent (VtyEvent (V.EvKey (V.KChar '-') [])) = modify $ changeTime False 175 | handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = modify changeItem 176 | handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = modify addPortal 177 | handleEvent (VtyEvent (V.EvKey (V.KChar 'e') [])) = modify addEmmiter 178 | handleEvent (VtyEvent (V.EvKey (V.KChar 'd') [])) = modify delItem 179 | handleEvent (VtyEvent (V.EvKey V.KEnter [])) = modify showSolutions 180 | handleEvent (VtyEvent (V.EvKey (V.KChar 'w') [])) = modify showWrongTrajectories 181 | handleEvent (VtyEvent (V.EvKey (V.KChar '1') [])) = modify $ solution univ1 182 | handleEvent (VtyEvent (V.EvKey (V.KChar '2') [])) = modify $ solution univ2 183 | handleEvent (VtyEvent (V.EvKey (V.KChar '3') [])) = modify $ solution univ3 184 | handleEvent (VtyEvent (V.EvKey (V.KChar '4') [])) = modify $ solution univ4 185 | handleEvent (VtyEvent (V.EvKey (V.KChar '5') [])) = modify $ solution univ5 186 | handleEvent (VtyEvent (V.EvKey (V.KChar '6') [])) = modify $ solution univ6 187 | handleEvent (VtyEvent (V.EvKey (V.KChar '7') [])) = modify $ solution univ7 188 | handleEvent (AppEvent Tick ) = modify increaseStep 189 | handleEvent _ = return () 190 | 191 | 192 | solution :: Univ -> UI -> UI 193 | solution u ui = set #initUniv u ui 194 | 195 | move' :: Dir -> UI -> UI 196 | move' d = updateUI (movePos d) 197 | 198 | movePos :: Dir -> PTD -> PTD 199 | movePos N (PTD (Pos x y) t d) = PTD (Pos x (y+1)) t d 200 | movePos S (PTD (Pos x y) t d) = PTD (Pos x (y-1)) t d 201 | movePos E (PTD (Pos x y) t d) = PTD (Pos (x+1) y) t d 202 | movePos W (PTD (Pos x y) t d) = PTD (Pos (x-1) y) t d 203 | 204 | rotate :: UI -> UI 205 | rotate = updateUI (turn' Right_) 206 | 207 | changeTime :: Bool -> UI -> UI 208 | changeTime b = updateUI (changeTime' b) 209 | 210 | changeTime' :: Bool -> PTD -> PTD 211 | changeTime' True (PTD p t d) = PTD p (t+1) d 212 | changeTime' False (PTD p t d) = PTD p (t-1) d 213 | 214 | changeItem :: UI -> UI 215 | changeItem ui@(UI u s _ _) = ui {selItem = nextSel (getSels u) s} 216 | 217 | nextSel :: (Eq a) => [a] -> Maybe a -> Maybe a 218 | nextSel [] _ = Nothing 219 | nextSel as Nothing = Just $ head as 220 | nextSel as (Just a) = case dropWhile (/=a) as of 221 | [] -> Nothing 222 | [_] -> Just $ head as 223 | _:b:_ -> Just b where 224 | 225 | getSels :: Univ -> [SelItem] 226 | getSels (Univ ps es cs) = portals ++ entries ++ exits where 227 | portals = concatMap (\i -> [SelItem EntryPortal i, SelItem ExitPortal i]) [0..length ps-1] 228 | entries = map (SelItem Entry) [0..length es-1] 229 | exits = map (SelItem Exit) [0..length cs-1] 230 | 231 | addPortal :: UI -> UI 232 | addPortal ui = changeItem $ over (#initUniv % #portals) (++ [portal1]) ui 233 | 234 | addEmmiter :: UI -> UI 235 | addEmmiter ui = changeItem $ over (#initUniv % #emitters) (++ [initSource]) ui 236 | 237 | delItem :: UI -> UI 238 | delItem = changeItem . delItem' 239 | 240 | delItem' :: UI -> UI 241 | delItem' ui@(UI _ (Just (SelItem EntryPortal i)) _ _) = over (#initUniv % #portals) (deleteAt i) ui 242 | delItem' ui@(UI _ (Just (SelItem ExitPortal i)) _ _) = over (#initUniv % #portals) (deleteAt i) ui 243 | delItem' ui@(UI _ (Just (SelItem Entry i)) _ _) = over (#initUniv % #emitters) (deleteAt i) ui 244 | delItem' ui@(UI _ (Just (SelItem Exit i)) _ _) = over (#initUniv % #consumers) (deleteAt i) ui 245 | delItem' ui = ui 246 | 247 | deleteAt i xs = ls ++ rs 248 | where (ls, _:rs) = splitAt i xs 249 | 250 | updateUI :: (PTD -> PTD) -> UI -> UI 251 | updateUI f ui@(UI _ (Just (SelItem EntryPortal i)) _ _) = over (#initUniv % #portals % ix i % #entry % #unSink) f ui 252 | updateUI f ui@(UI _ (Just (SelItem ExitPortal i)) _ _) = over (#initUniv % #portals % ix i % #exit % #unSource) f ui 253 | updateUI f ui@(UI _ (Just (SelItem Entry i)) _ _) = over (#initUniv % #emitters % ix i % #unSource) f ui 254 | updateUI f ui@(UI _ (Just (SelItem Exit i)) _ _) = over (#initUniv % #consumers % ix i % #unSink) f ui 255 | updateUI f ui = ui 256 | 257 | increaseStep :: UI -> UI 258 | increaseStep (UI ps s st c) = UI ps s (st+1) c 259 | 260 | showSolutions :: UI -> UI 261 | showSolutions = over (#config % #showSols) not 262 | 263 | showWrongTrajectories :: UI -> UI 264 | showWrongTrajectories = over (#config % #showWrongTrajs) not 265 | 266 | -- * Attributes 267 | 268 | dimA, selA :: AttrName 269 | dimA = attrName "Dim" 270 | selA = attrName "Sel" 271 | portalA n = attrName $ "Portal" ++ show n 272 | borderGood = attrName "borderGood" 273 | borderBad = attrName "borderBad" 274 | 275 | portalColors :: [VA.Color] 276 | portalColors = [VA.yellow, VA.blue, VA.green] 277 | 278 | 279 | theMap :: UI -> AttrMap 280 | theMap (UI _ _ st _) = attrMap 281 | V.defAttr $ 282 | [(dimA, VA.withStyle VA.defAttr VA.dim), 283 | (borderGood, fg VA.green), 284 | (borderBad, fg VA.red), 285 | (selA, if even (st `div` 5) then VA.withStyle VA.defAttr VA.bold else VA.defAttr)] 286 | ++[ (portalA n, fg (portalColors !! n)) | n <- [0.. length portalColors - 1]] 287 | 288 | 289 | help :: String 290 | help = "Keyboard arrows: move selected item\n" ++ 291 | "\'r\': rotate\n" ++ 292 | "\'+/-\': increase/decrease time\n" ++ 293 | "Space: change selected item\n" ++ 294 | "Enter: Show/Hide solutions\n" ++ 295 | "\'p\': add portal\n" ++ 296 | "\'e\': add emitter\n" ++ 297 | "\'d\': delete item\n" ++ 298 | "---------------------\n" ++ 299 | "Load examples:\n" ++ 300 | "\'1\': The Paradox\n" ++ 301 | "\'2\': Self-rightening solution\n" ++ 302 | "\'3\': The Djinn\n" ++ 303 | "\'4\': Djinn deviation\n" ++ 304 | "\'5\': The Northern Cross\n" ++ 305 | "\'6\': Kill one solution with Paradox\n" ++ 306 | "\'7\': 4 solutions\n" 307 | 308 | 309 | encouragement :: Bool -> Int -> String 310 | encouragement False _ = "Press Enter when you are ready." 311 | encouragement _ 0 = "No solutions! You've hit a paradox. Press \'w\' to see why." 312 | encouragement _ 1 = "There is only one possible trajectory." 313 | encouragement _ n = "There are " ++ show n ++ " possible trajectories." 314 | -------------------------------------------------------------------------------- /dist-newstyle/sdist/timetravel-0.1.0.0.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/dist-newstyle/sdist/timetravel-0.1.0.0.tar.gz -------------------------------------------------------------------------------- /img/simple.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/img/simple.png -------------------------------------------------------------------------------- /img/sol1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/img/sol1.gif -------------------------------------------------------------------------------- /img/sol2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/img/sol2.gif -------------------------------------------------------------------------------- /img/start.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/img/start.png -------------------------------------------------------------------------------- /img/whole.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdupont/Timeloop/f1cbca4ec9afb2c8a45878ca58537a50713a54e8/img/whole.gif -------------------------------------------------------------------------------- /src/TimeLoop/Search.hs: -------------------------------------------------------------------------------- 1 | module TimeLoop.Search where 2 | 3 | import Prelude hiding (Left, Right) 4 | import Data.List 5 | import Data.Ord 6 | import Data.Function 7 | import Data.Maybe (listToMaybe, catMaybes) 8 | import Control.Applicative 9 | import Control.Monad 10 | import TimeLoop.Types 11 | import TimeLoop.Walker 12 | import Data.Array 13 | import Control.Scanl 14 | import Control.Monad.State 15 | 16 | -- Get all blocks that contains valid trajectories for the given universe 17 | getValidSTBlocks :: Univ -> [STBlock] 18 | getValidSTBlocks u = filter isValidBlock $ getAllSTBlocks u 19 | 20 | getAllSTBlocks :: Univ -> [STBlock] 21 | getAllSTBlocks u@(Univ ps es cs) = map getSTBlock $ getPortalCombinations ps where 22 | getSTBlock :: [Source] -> STBlock 23 | getSTBlock scs = STBlock u $ join $ elems $ getAllWalkers $ getTimeline (scs ++ es) (cs ++ map entry ps) 24 | 25 | 26 | -- A portal can emit a walker, or not. 27 | -- We simulate all possible combinations of portal usage. 28 | getPortalCombinations :: [Portal] -> [[Source]] 29 | getPortalCombinations ps = subsequences $ map exit ps 30 | 31 | -- Get a list of Sources and Sinks, indexed by their time. 32 | getTimeline :: [Source] -> [Sink] -> Array Time ([Source], [Sink]) 33 | getTimeline emitters consumers = listArray (0, maxStep) $ map getIOT [0..maxStep] where 34 | getIOT t = (filter (\(Source (PTD _ t' _)) -> t == t') emitters, 35 | filter (\(Sink (PTD _ t' _)) -> t == t') consumers) 36 | 37 | -- generate the full universe of walkers from a timeline. 38 | getAllWalkers :: Array Time ([Source], [Sink]) -> Array Time [Walker] 39 | getAllWalkers timeline = snd $ mapAccumL getNextStep [] timeline 40 | 41 | -- Move the walkers one step. 42 | -- All walkers, sources, sinks should be from the same time frame. 43 | getNextStep :: [Walker] -> ([Source], [Sink]) -> ([Walker], [Walker]) 44 | getNextStep ws (sources, sinks) = 45 | -- We move all walkers on step. New walkers appears on the sources. Walkers that are on a Sink are removed. 46 | -- This will be used by mapAccumL as input for the next step 47 | (concatMap move $ posGroups $ (ws ++ emitted) \\ consummed, 48 | -- We store the current walkers, together with the new walkers appearing at the sources. 49 | -- This will be stored by mapAccumL in the final array 50 | ws ++ emitted) 51 | where 52 | posGroups as = groupBy ((==) `on` position) $ sortOn position as 53 | consummed = map (Walker . unSink) sinks 54 | emitted = map (Walker . unSource) sources 55 | position (Walker (PTD p _ _)) = p 56 | 57 | -- A Universe is valid when a walker that enters a portal, also exits it. 58 | isValidBlock :: STBlock -> Bool 59 | isValidBlock (STBlock (Univ ps _ _) ws) = all (isValidPortal ws) ps where 60 | isValidPortal ws (Portal (Sink sk) (Source sc)) = (sc `elem` ws') == (sk `elem` ws') 61 | ws' = map unWalker ws 62 | 63 | dupe :: a -> (a,a) 64 | dupe x = (x,x) 65 | 66 | -------------------------------------------------------------------------------- /src/TimeLoop/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MonadComprehensions #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | 7 | module TimeLoop.Types where 8 | 9 | import GHC.Generics (Generic) 10 | import Optics.Label 11 | 12 | data Dir = N | E | S | W 13 | deriving (Eq, Ord, Show, Enum, Bounded) 14 | 15 | data RelDir = Front | Back | Right_ | Left_ 16 | deriving (Eq, Ord, Show, Enum, Bounded) 17 | 18 | type Time = Int 19 | 20 | data Pos = Pos { 21 | x :: Int, 22 | y :: Int} 23 | deriving (Eq, Ord, Show, Generic) 24 | 25 | data PTD = PTD { 26 | pos :: Pos, 27 | time :: Time, 28 | dir :: Dir} 29 | deriving (Eq, Ord, Show, Generic) 30 | 31 | --instance Show PTD where 32 | -- show (PTD (Pos x y) t d) = show x ++ ", " ++ show y ++ ", " ++ show t ++ " " ++ (show d) 33 | 34 | -- An Walker is a particle with a position, a time and a direction. 35 | newtype Walker = Walker {unWalker :: PTD} 36 | deriving (Eq, Ord, Show, Generic) 37 | 38 | newtype Source = Source {unSource :: PTD} 39 | deriving (Eq, Ord, Show, Generic) 40 | 41 | newtype Sink = Sink {unSink :: PTD} 42 | deriving (Eq, Ord, Show, Generic) 43 | 44 | -- A portal links two points in space, at specific times and directions. 45 | data Portal = Portal { 46 | entry :: Sink, 47 | exit :: Source} 48 | deriving (Eq, Ord, Show, Generic) 49 | 50 | -- A Univers contains some portals linking distant points in the spacetime block. 51 | -- It also contains emitters and consumers which are point emitting or consuming one walker. 52 | data Univ = Univ { 53 | portals :: [Portal], 54 | emitters :: [Source], 55 | consumers :: [Sink]} 56 | deriving (Eq, Ord, Show, Generic) 57 | 58 | -- A STBlock is infinite and flat spacetime block universe. 59 | -- It contains some "Walkers" which are particules that moves in a straight line. 60 | data STBlock = STBlock { 61 | univ :: Univ, 62 | walkers :: [Walker]} 63 | deriving (Eq, Show, Generic) 64 | 65 | type Limits = ((Int, Int), (Int, Int)) 66 | 67 | maxStep :: Int 68 | maxStep = 10 69 | 70 | -- sample data * 71 | 72 | initSource :: Source 73 | initSource = Source (PTD (Pos 0 0) 0 E) 74 | 75 | source1 :: Source 76 | source1 = Source (PTD (Pos 1 (-1)) 0 N) 77 | 78 | source2 :: Source 79 | source2 = Source (PTD (Pos 0 3) 0 E) 80 | 81 | sink1 :: Sink 82 | sink1 = Sink (PTD (Pos 5 0) 5 E) 83 | 84 | walker1 :: Walker 85 | walker1 = Walker (PTD (Pos 0 0) 0 E) 86 | 87 | walker2 :: Walker 88 | walker2 = Walker (PTD (Pos 0 0) 0 N) 89 | 90 | walker3 :: Walker 91 | walker3 = Walker (PTD (Pos 5 5) 0 N) 92 | 93 | portal1 :: Portal 94 | portal1 = Portal (Sink (PTD (Pos 0 0) 0 S)) (Source (PTD (Pos 1 0) 1 W)) 95 | 96 | --No solution (self deviating) 97 | univ1 :: Univ 98 | univ1 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 6, y = 0}, time = 6, dir = E}}, exit = Source {unSource = PTD {pos = Pos {x = 3, y = 3}, time = 0, dir = S}}}], emitters = [Source {unSource = PTD {pos = Pos {x = 0, y = 0}, time = 0, dir = E}}], consumers = []} 99 | 100 | --two solutions: going straight or going through portal 101 | univ2 :: Univ 102 | univ2 = Univ 103 | [Portal (Sink (PTD (Pos 3 (-3)) 6 S)) (Source (PTD (Pos 6 0) 0 W))] 104 | [Source (PTD (Pos 0 0) 0 E)] 105 | [] 106 | 107 | -- The Djinn 108 | univ3 :: Univ 109 | univ3 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 6, y = 0}, time = 6, dir = E}}, exit = Source {unSource = PTD {pos = Pos {x = 0, y = 0}, time = 0, dir = E}}}], emitters = [], consumers = []} 110 | 111 | --One solution: Deviate a Djinn 112 | univ4 :: Univ 113 | univ4 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 6, y = 0}, time = 6, dir = E}}, exit = Source {unSource = PTD {pos = Pos {x = 3, y = -3}, time = 0, dir = N}}}], emitters = [Source {unSource = PTD {pos = Pos {x = 0, y = 0}, time = 0, dir = E}}], consumers = []} 114 | 115 | -- The northern cross 116 | univ5 :: Univ 117 | univ5 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 3, y = -3}, time = 6, dir = S}}, exit = Source {unSource = PTD {pos = Pos {x = 6, y = 0}, time = 0, dir = W}}},Portal {entry = Sink {unSink = PTD {pos = Pos {x = 3, y = 3}, time = 6, dir = N}}, exit = Source {unSource = PTD {pos = Pos {x = 0, y = 0}, time = 0, dir = E}}}], emitters = [], consumers = []} 118 | 119 | -- Kill one solution 120 | univ6 :: Univ 121 | univ6 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 3, y = -3}, time = 6, dir = S}}, exit = Source {unSource = PTD {pos = Pos {x = 6, y = 0}, time = 0, dir = W}}},Portal {entry = Sink {unSink = PTD {pos = Pos {x = 3, y = 3}, time = 6, dir = N}}, exit = Source {unSource = PTD {pos = Pos {x = 1, y = 2}, time = 3, dir = E}}}], emitters = [Source {unSource = PTD {pos = Pos {x = 0, y = 0}, time = 0, dir = E}}], consumers = []} 122 | 123 | -- 4 solutions 124 | univ7 :: Univ 125 | univ7 = Univ {portals = [Portal {entry = Sink {unSink = PTD {pos = Pos {x = 3, y = -3}, time = 4, dir = S}}, exit = Source {unSource = PTD {pos = Pos {x = 5, y = -1}, time = 0, dir = W}}},Portal {entry = Sink {unSink = PTD {pos = Pos {x = 5, y = 1}, time = 6, dir = E}}, exit = Source {unSource = PTD {pos = Pos {x = 1, y = 1}, time = 2, dir = E}}}], emitters = [Source {unSource = PTD {pos = Pos {x = 1, y = -1}, time = 0, dir = E}}], consumers = []} 126 | 127 | -------------------------------------------------------------------------------- /src/TimeLoop/Walker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | 3 | module TimeLoop.Walker where 4 | 5 | import TimeLoop.Types 6 | import Optics 7 | import Optics.Label 8 | 9 | -- move one or several walkers that are at the same point in spacetime 10 | -- in case of collision, we always turn right 11 | move :: [Walker] -> [Walker] 12 | move [w] = [simpleMove w] 13 | move ws = map (simpleMove . turn Right_) ws 14 | 15 | -- Move one step in a flat universe. 16 | simpleMove :: Walker -> Walker 17 | simpleMove w = case view (#unWalker % #dir) w of 18 | N -> over (#unWalker % #pos % #y) (+1) w' 19 | S -> over (#unWalker % #pos % #y) (subtract 1) w' 20 | E -> over (#unWalker % #pos % #x) (+1) w' 21 | W -> over (#unWalker % #pos % #x) (subtract 1) w' 22 | where 23 | w' = over (#unWalker % #time) (+1) w 24 | 25 | -- Turn a walker using a relative direction 26 | turn :: RelDir -> Walker -> Walker 27 | turn rd = over #unWalker (turn' rd) 28 | 29 | turn' :: RelDir -> PTD -> PTD 30 | turn' rd = over #dir (turnRel rd) 31 | 32 | -- Turn an absolute direction using a relative one 33 | turnRel :: RelDir -> Dir -> Dir 34 | turnRel Right_ W = N 35 | turnRel Right_ d = succ d 36 | turnRel Left_ N = W 37 | turnRel Left_ d = pred d 38 | turnRel Back a = turnRel Right_ $ turnRel Right_ a 39 | turnRel Front a = a 40 | 41 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /timetravel.cabal: -------------------------------------------------------------------------------- 1 | name: timetravel 2 | version: 0.1.0.0 3 | description: Please see the README on GitHub at 4 | homepage: https://github.com/cdupont/timetravel#readme 5 | bug-reports: https://github.com/cdupont/timetravel/issues 6 | author: Corentin Dupont 7 | maintainer: corentin.dupont@gmail.com 8 | copyright: 2021 Corentin Dupont 9 | license: BSD3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | 14 | extra-source-files: 15 | ChangeLog.md 16 | README.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/cdupont/timetravel 21 | 22 | library 23 | hs-source-dirs: 24 | src 25 | build-depends: 26 | base >= 4.9 27 | , optparse-simple 28 | , brick == 2.1 29 | , split 30 | , vty == 6.0 31 | , containers 32 | , optics 33 | , optics-th 34 | , array 35 | , foldl 36 | , mtl 37 | exposed-modules: 38 | TimeLoop.Search 39 | TimeLoop.Walker 40 | TimeLoop.Types 41 | other-modules: 42 | Paths_timetravel 43 | default-language: Haskell2010 44 | 45 | executable timetravel 46 | main-is: Main.hs 47 | hs-source-dirs: 48 | app 49 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 50 | build-depends: 51 | base >= 4.9 52 | , optparse-simple 53 | , brick == 2.1 54 | , split 55 | , vty == 6.0 56 | , vty-crossplatform 57 | , containers 58 | , optics 59 | , timetravel 60 | other-modules: 61 | UI 62 | Tile 63 | default-language: Haskell2010 64 | 65 | --------------------------------------------------------------------------------