Temp.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import qualified Prelude
import Prelude hiding (words)
import Data.Char (isSpace, isSymbol)
import Data.Foldable (asum)
import Data.Maybe (fromMaybe)
import Options.Applicative
import Data.Semigroup ((<>))
import Control.Monad
import Control.Concurrent
import Control.Exception.Base (bracket)
import System.IO
import Data.Text (Text)
import qualified Data.Text as Text
-- import qualified Data.Text.IO as Text
import Data.Vector (Vector, (!))
import qualified Data.Vector as Vector

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :m +GHC.TypeLits
-- >>> import Text.Show.Pretty (pPrint)
-- >>> :set -interactive-print pPrint

{-
  -- sync via MVar?
data State
  { frameTimer  :: !ThreadId
  , lastFrame   :: !Time
  , fps         :: !Double
  , direction   :: !Direction
  , mode        :: !Mode
  , current     :: !Position
  }
-}

data TextIndex = TextIndex
  { paragraphs  :: !(Vector (Range SentenceIndex))
  , sentences   :: !(Vector (Range WordIndex))
  , words       :: !(Vector (Range CharacterIndex))
  , chars       :: !Text
  , numParagraphs :: !Int
  , numSentences  :: !Int
  , numWords      :: !Int
  , numChars      :: !Int
  }
  deriving Show

(!#) :: Text -> Int -> Char
(!#) = Text.index

-- |
-- 'textIndex' finds the location of each word, sentence, and paragraph in the
-- given text.
--
-- >>> textIndex "Hello"
-- TextIndex
--   { paragraphs = [ ( 0 , 0 ) ]
--   , sentences = [ ( 0 , 0 ) ]
--   , words = [ ( 0 , 4 ) ]
--   , chars = "Hello"
--   , numParagraphs = 1
--   , numSentences = 1
--   , numWords = 1
--   , numChars = 5
--   }
--
-- Words are whitespace delimited and a single sentence can span multiple
-- lines.
--
-- >>> textIndex "  able\nbaker  charlie\ndelta  "
-- TextIndex
--   { paragraphs = ...
--   , sentences = [ ( 0 , 3 ) ]
--   , words = [ ( 2 , 5 ) , ( 7 , 11 ) , ( 14 , 20 ) , ( 22 , 26 ) ]
--   ...
--   }
--
-- Sentences are terminated by the usual punctuation marks, or by double
-- line breaks.
--
-- >>> textIndex "'I like cheese!' No really? Yes. That's fine\n\nBye!"
-- TextIndex
--  { paragraphs = ...
--  , sentences =
--      [ ( 0 , 2 )
--      , ( 3 , 4 )
--      , ( 5 , 5 )
--      , ( 6 , 7 )
--      , ( 8 , 8 )
--      ]
--  ...
--  }
--
textIndex :: Text -> TextIndex
textIndex chars = TextIndex {..} where
  numChars = Text.length chars

  numWords = Vector.length words
  words = Vector.fromList $ findWordStart 0

  findWordStart i
    | i == numChars       = []
    | isSpace (chars !# i)= findWordStart (i + 1)
    | otherwise           = findWordEnd i (i + 1)
  findWordEnd i j
    | j == numChars       = (i,j-1) : []
    | isSpace (chars !# j) = (i,j-1) : findWordStart (j + 1)
    | otherwise           =           findWordEnd i (j + 1)

  sentences = Vector.fromList $ findSentenceStart 0
  numSentences = Vector.length sentences

  findSentenceStart i
    | i == numWords       = []
    | otherwise           = findSentenceEnd i i
  findSentenceEnd i j
    | j == numWords - 1   = (i,j) : []
    | isEndOfSentence j   = (i,j) : findSentenceStart (j + 1)
    | otherwise           =         findSentenceEnd i (j + 1)

  isEndOfSentence k = fromMaybe (isEndOfParagraph k) . asum $ do
    let (lo,hi) = words ! k
    ch <- (chars !#) <$> [hi,hi-1..lo]
    return $ case () of 
      _ | ch `elem` ".!?"   -> Just True
        | isSymbol ch       -> Nothing
        | otherwise         -> Just False

  paragraphs = Vector.fromList $ findParagraphStart 0
  numParagraphs = Vector.length paragraphs

  findParagraphStart i
    | i == numSentences   = []
    | otherwise           = findParagraphEnd i i
  findParagraphEnd i j
    | j == numSentences - 1 = (i,j) : []
    | isEndOfParagraph k    = (i,j) : findParagraphStart (j + 1)
    | otherwise             =         findParagraphEnd i (j + 1)
    where (_,k) = sentences ! j

  isEndOfParagraph k = 2 <= length 
    [ ()
    | let lo = snd (words ! k) + 1
    , let hi = fst (words ! (k + 1)) - 1
    , i <- [lo..hi]
    , chars !# i == '\n'
    ]

type Range i = (i,i)
type ParagraphIndex = Int
type SentenceIndex = Int
type WordIndex = Int
type CharacterIndex = Int

data Mode 
  = Starting
  | Reading
  | Paused { withHelp :: !Bool }
  | Unpausing
  | Done


data Position = Position
  { paragraph :: !Word
  , sentence :: !Word
  , word :: !Word
  }

-- |
-- >>> Position 409 0 1
-- 409.0.1
instance Show Position where
  showsPrec _ Position{..}
    = shows paragraph . showString "." . shows sentence . showString "." . shows word


-- |
-- >>> paragraph $ read "409.0.1"
-- 409
-- >>> sentence $ read "409.0.1"
-- 0
-- >>> word $ read "409.0.1"
-- 1
instance Read Position where
  readsPrec _ = go where
    go ( splitDot -> (reads -> [(paragraph, "")]
       , splitDot -> (reads -> [(sentence, "")]
       ,              reads -> [(word, "")])))
      = [(Position{..}, "")]
    go _ = []

    splitDot = fmap tail <$> break ('.'==)

data Options = Options
  { wpm :: Float
  , start :: Position
  , path :: String
  }
  deriving Show

options :: ParserInfo Options
options = info 
  (   Options <$> option auto 
                  (   long "wpm"
                  <>  help "Words to print per minute"
                  <>  showDefault
                  <>  value 250
                  <>  metavar "N"
                  )
              <*> option auto
                  (   long "pos"
                  <>  help "Starting position in the text"
                  <>  showDefault
                  <>  value (Position 0 0 0)
                  <>  metavar "PARAGRAPH.SENTENCE.WORD"
                  )
              <*> argument str
                  (   help "File to read from"
                  <>  metavar "PATH"
                  )
  <**> helper
  )
  (   fullDesc
  <>  progDesc "Print a file one word at a time at a given wpm"
  <>  header "spreto - a speed-reading tool"
  )

hideCursor, showCursor :: IO ()
hideCursor = putStr "\ESC[?25l" >> hFlush stdout
showCursor = putStr "\ESC[?25h" >> hFlush stdout

-- |
-- Approximate the "optimal recognition point" (ORP) for a given word,
-- the character that should be aligned and highlighted when the word is
-- printed.
--
-- >>> orp "a"
-- 0
-- >>> orp "to"
-- 1
-- >>> orp "now"
-- 1
-- >>> orp "word"
-- 1
-- >>> orp "using"
-- 1
-- >>> orp "slower"
-- 2
-- >>> orp "reading"
-- 2
-- >>> orp "provides"
-- 2
-- >>> orp "delivered"
-- 2
-- >>> orp "technology"
-- 3
orp :: String -> Int
-- XXX: Expect to spend a lot of time tweaking this
--
-- There examples seem mostly word-length based, but it
-- also seems like capital letters are weighed extra, while
-- common suffices (e.g. -ing, -ed) are weighed less.
--
-- We'll probably also want to account for punctuation.
--
-- We/lcome t/o sp/ritzing!
-- R/ight n/ow y/ou a/re u/sing o/ur inn/ovative re/ading tec/hnology 
-- E/ach w/ord i/s de/livered t/o y/our e/yes i/n t/he pe/rfect po/sition 
-- In/stead o/f y/ou 
orp w = (length w + 2) `div` 4

intro :: IO ()
intro = do
  let n = lcm (59*8) (20*3)
      runtimeInMicroseconds = 3000000
      microsecondsPerBar = runtimeInMicroseconds `div` n
      lefts  = "" : map return "▏▎▍▌▋▊▉" 
      rights = "" : map return "▕▐"
  forM_ [n,n-1..0] $ \i -> do
    let (rfull,rpart) = (20 * i) `quotRem` n
        (lfull,lpart) = (59 * i) `quotRem` n
        full = rfull + lfull + 1
        prefix = rights !! quot (3 * rpart) n
        suffix = lefts  !! quot (8 * lpart) n
        indent = 20 - rfull - if null prefix then 0 else 1
    putStrLn $ concat
      -- \ESC[<N>C - move cursor N columns right
      [ "\ESC[F\ESC[K\ESC[", show indent, "C"
      , prefix, replicate full '█', suffix
      ]
    threadDelay microsecondsPerBar

main :: IO ()
main = bracket hideCursor (const showCursor) $ \_ -> do
  Options{..} <- execParser options
  ws <- Prelude.words <$> readFile path
  putStrLn "────────────────────┬───────────────────────────────────────────────────────────"
  putStrLn ""
  -- \ESC[F - move cursor to beginning of previous line
  putStrLn "────────────────────┴───────────────────────────────────────────────────────────\ESC[F"
  intro
  let delay = round (60 * 1000000 / wpm)
  forM_ ws $ \w -> do
    let n = orp w
    let ~(xs,y:ys) = splitAt n w
    -- \ESC[K - clear to end of line
    -- \ESC[31m - change foreground color to red
    -- \ESC[m - reset foreground color
    putStrLn $ "\ESC[F\ESC[K" ++ replicate (20 - n) ' ' ++ xs ++ "\ESC[31m" ++ [y] ++ "\ESC[m" ++ ys
    hFlush stdout
    threadDelay delay