packages feed

schedevr 0.1.0.0 → 0.1.0.1

raw patch · 6 files changed

+314/−3 lines, 6 files

Files

schedevr.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                schedevr-version:             0.1.0.0+version:             0.1.0.1 synopsis:            Marge schedules and show EVR -- description:          license:             BSD3@@ -18,7 +18,7 @@ executable marge-schedule   hs-source-dirs:      src/mkschd   main-is:             marge-schedule.hs-  -- other-modules:       +  other-modules:       FromID, Output, Parser   other-extensions:    TupleSections   build-depends:       base >=4.6 && <4.7, xturtle >=0.1 && <0.2, time >=1.4 && <1.5, filepath >=1.3 && <1.4, old-locale >=1.0 && <1.1   hs-source-dirs:      src@@ -27,7 +27,7 @@ executable show-progress   hs-source-dirs:      src/mkschd, src/prog_graph   main-is:             mkGraph.hs-  -- other-modules:       +  other-modules:       ScheduleEVR, WatchEVR   other-extensions:    TupleSections   build-depends:       base >=4.6 && <4.7, xturtle >=0.1 && <0.2, time >=1.4 && <1.5, filepath >=1.3 && <1.4, old-locale >=1.0 && <1.1, directory   hs-source-dirs:      src
+ src/mkschd/FromID.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TupleSections #-}++module FromID (convertOutput) where++import Parser+import Output+import Control.Applicative+import Data.Maybe++fromID :: String -> String -> Maybe String+fromID tbl i = lookup i (map parseItemList $ lines tbl)++convertOutput :: String -> Output -> Output+convertOutput tbl (d, i) = fromJust $ (d ,) <$> fromID tbl i
+ src/mkschd/Output.hs view
@@ -0,0 +1,75 @@+module Output (+	Output, showOutputs, evrOutputs, fromItem, fromItem2, fromItemN+) where++import Parser+import Data.Time+import System.Locale++type Output = ((Day, Day), String)++evrOutputs :: [Output] -> String+evrOutputs = unlines . map evrOutput++evrOutput :: Output -> String+evrOutput ((_, e), i) = i ++ "\t" ++ show e++showOutputs :: [Output] -> String+showOutputs = unlines . map showOutput++showOutput :: Output -> String+showOutput ((b, e), c)+	| b >= e = showDay b ++ replicate 7 ' ' ++ c+	| otherwise = showDay b ++ "-" ++ showDay e ++ " " ++ c+	where+	showDay = formatTime defaultTimeLocale "%m/%d"++fromItem :: Day -> [Item] -> [Output]+fromItem _ [] = []+fromItem d ia@(i : is)+	| isOK i d = ((d, pred $ ending i d), contents i) : fromItem (ending i d) is+	| isLate i d = error "too late"+	| otherwise = fromItem (succ d) ia++fromItem2 :: Day -> [Item] -> [Item] -> [Output]+fromItem2 d ia1 [] = fromItem d ia1+fromItem2 d [] ia2 = fromItem d ia2+fromItem2 d ia1@(i1 : is1) ia2@(i2 : is2)+--	| isLate i1 e2 && isLate i2 e1 = error "too late"+	| isOK i1 d && isLate i2 e1 =+		((d, pred e1), contents i1) : fromItem2 e1 is1 ia2+	| isLate i1 e2 && isOK i2 d =+		((d, pred e2), contents i2) : fromItem2 e2 is2 ia1+	| isOK i1 d =+		((d, pred e1), contents i1) : fromItem2 e1 is1 ia2+	| isOK i2 d =+		((d, pred e2), contents i2) : fromItem2 e2 is2 ia1+	| not (isLate i1 d) && not (isLate i2 d) = fromItem2 (succ d) ia1 ia2+	| otherwise = error "too late"+	where+	e1 = ending i1 d+	e2 = ending i2 d++fromItemN :: Day -> [[Item]] -> [Output]+fromItemN _ [] = []+fromItemN d ias+	| any null ias = fromItemN d $ filter (not . null) ias+	| any (flip isLate d) (map head ias) = error "too late"+fromItemN d ias = fromItemNSelect [] d es diag ias+	where+	es = map (flip ending d . head) ias+	diag = diagonal $ map head ias++fromItemNSelect :: [[Item]] -> Day -> [Day] -> [[Item]] -> [[Item]] -> [Output]+fromItemNSelect pre d [] [] [] = fromItemN (succ d) pre+fromItemNSelect pre d (e : es) (diag : diags) ((i : is) : ias)+	| check d i e diag =+		((d, pred e), contents i) : fromItemN e (is : pre ++ ias)+fromItemNSelect pre d (e : es) (diag : diags) (ia : ias) =+	fromItemNSelect (ia : pre) d es diags ias++diagonal :: [a] -> [[a]]+diagonal xs = map (\i -> take i xs ++ drop (i + 1) xs) [0 .. length xs - 1]++check :: Day -> Item -> Day -> [Item] -> Bool+check d i e diags = isOK i d && all (not . flip isLate e) diags
+ src/mkschd/Parser.hs view
@@ -0,0 +1,62 @@+module Parser (+	parse, LES, Item, isOK, isLate, ending, contents,+	parseItemList) where++import Data.List+import Data.Time+import Data.Maybe+import Data.Char+import Control.Arrow++data LES = SmallerThan | NoLargerThan | Equal | NoSmallerThan | LargerThan | Always+	deriving (Show, Enum, Eq)++type Item = (((LES, Day), Integer), String)++isOK :: Item -> Day -> Bool+isOK (((les, d), _), _) = flip (op les) d++isLate :: Item -> Day -> Bool+isLate (((SmallerThan, d), _), _) = (d <=)+isLate (((NoLargerThan, d), _), _) = (d <)+isLate (((Equal, d), _), _) = (d <)+isLate _ = const False++ending :: Item -> Day -> Day+ending ((_, s), _) = addDays s++contents :: Item -> String+contents = snd++readLES :: String -> Maybe LES+readLES = flip lookup $ zip ["<", "<=", "=", ">=", ">", ""] [SmallerThan ..]++op :: LES -> (Day -> Day -> Bool)+op = fromJust . flip lookup (zip [SmallerThan ..]+	[(<), (<=), (==), (>=), (>), const $ const True])++parse :: String -> [Item]+parse = map parseLine . lines++parseLine :: String -> Item+parseLine str = case split (== ':') str of +	[d, s, c] -> ((parseDay d, read s), c)+	_ -> error "bad number of fields of line"++split :: (Char -> Bool) -> String -> [String]+split s = unfoldr $ \xs -> case (xs, span (not . s) xs) of+	([], _) -> Nothing+	(_, (_, [])) -> Just (dropSpaces xs, [])+	(_, (r, _ : xs')) -> Just (dropSpaces r, xs')++parseDay :: String -> (LES, Day)+parseDay "" = (Always, read "0000-00-00")+parseDay s = (fromJust . readLES *** read) $ span (not . isDigit) s++dropSpaces :: String -> String+dropSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace++parseItemList :: String -> (String, String)+parseItemList str = (is !! 0, is !! 2)+	where+	is = split (== ':') str
+ src/prog_graph/ScheduleEVR.hs view
@@ -0,0 +1,13 @@+module ScheduleEVR (dayItem, dayItemFile) where++import Output+import Parser+import FromID+import Data.Time+import Control.Applicative++dayItemFile :: Day -> [FilePath] -> IO [(Day, String)]+dayItemFile b = (dayItem b <$>) . mapM readFile++dayItem :: Day -> [String] -> [(Day, String)]+dayItem b = ((b, "start") :) . map (\((_, e), i) -> (e, i)) . fromItemN b . map parse
+ src/prog_graph/WatchEVR.hs view
@@ -0,0 +1,147 @@+module WatchEVR (+	idPoint', dayId, accumSecond, dayPoint, getConverter, progPercent,+	waku, chart, fontsize+) where++import Graphics.X11.Turtle+import Data.List+import Data.Time+import Data.Maybe+import Control.Arrow+import System.Environment+import System.FilePath+import Data.Char++evrItemsName, evrScheduleName, evrProgressName :: FilePath+-- evrItemsName = "evr_items.txt"+evrItemsName = "item_list"+evrScheduleName = "evr_schedule"+evrProgressName = "progress"++main :: IO ()+main = do+	prog <- getProgName+	path <- getExecutablePath+	let dir = takeDirectory path ++ "/"+	eiCnt <- readFile $ dir ++ evrItemsName+	esCnt <- readFile $ dir ++ evrScheduleName+	espCnt <- readFile $ dir ++ evrProgressName+	let+--		ei = map idPoint $ tail $+--			dropWhile (not . isPrefixOf "* タイトル") $ lines eiCnt+		ei = map idPoint' $ lines eiCnt+		es = map dayId $ lines esCnt+		esp = map dayId $ lines espCnt+		di = accumSecond (+) 0 $ dayPoint ei es+		dip = accumSecond (+) 0 $ dayPoint ei esp+		cnv = getConverter (50, 100) (400, 200) di+		pc = progPercent dip di+	f <- openField+	topleft f+	t <- newTurtle f+	speed t "fastest"+	flushoff t+	waku t (50, 100) (400, 200) di+	goto t 50 300+	flushon t+	speed t "slowest"+	chart t "grey" cnv (50, 100) (400, 200) di+	speed t "slow"+	goto t 50 300+	speed t "slowest"+	chart t "black" cnv (50, 100) (400, 200) dip+	speed t "fastest"+	goto t 200 100+	write t "Kochi Gothic" fontsize $ take 4 (show pc) ++ "%"+	hideturtle t+	onkeypress f $ return . (/= 'q')+	waitField f++progPercent :: [(Day, Int)] -> [(Day, Int)] -> Double+progPercent p s = 100 *+	fromIntegral (getPoint p) / fromIntegral (getPoint s)++getPoint :: [(Day, Int)] -> Int+getPoint = snd . last++idPoint :: String -> (String, Int)+idPoint ln = (i, read $ dropWhile (== '\t') p)+	where+	(i, p) = span (/= '\t') $ dropWhile (== '\t') $ dropWhile (/= '\t') ln++idPoint' :: String -> (String, Int)+idPoint' str = (is !! 0, read $ is !! 1)+	where+	is = split ':' str++split :: Char -> String -> [String]+split _ "" = []+split c str = case span (/= c) str of+	(s, "") -> [deleteSpaces s]+	(s, _ : r) -> deleteSpaces s : split c r++deleteSpaces :: String -> String+deleteSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace++dayId :: String -> (Day, String)+dayId ln = (read d, i)+	where+	(i, d) = span (/= '\t') ln++dayPoint :: [(String, Int)] -> [(Day, String)] -> [(Day, Int)]+dayPoint tbl = map $ second $ fromJust . flip lookup tbl++accumSecond :: (c -> b -> c) -> c -> [(a, b)] -> [(a, c)]+accumSecond op r0 [] = []+accumSecond op r0 ((x1, y1) : ps) =+	(x1, r0 `op` y1) : accumSecond op (r0 `op` y1) ps++fontsize = 10++chart :: (Enum x, Enum y, Ord x, Show x, ColorClass c) => Turtle -> c ->+	((x, y) -> (Double, Double)) ->+	(Double, Double) -> (Double, Double) -> [(x, y)] -> IO ()+chart t c converter tl@(left, top) wh@(width, height) dt = do+	pencolor t c+	turtleChart t $ map converter dt+	penup t++waku t tl@(left, top) wh@(width, height) dt = do+		penup t+		goto t left (top + height)+		pendown t+		goto t (left + width) (top + height)+		penup t+		goto t left (top + height)+		pendown t+		goto t left top+		penup t+		goto t (left - fontsize * 2) (top + height + fontsize * 1.5)+		write t "Kochi Gothic" fontsize $ show minx+		goto t (left + width - fontsize * 2) (top + height + fontsize * 1.5)+		write t "Kochi Gothic" fontsize $ show maxx+	where+	minx = minimum $ map fst dt+	maxx = maximum $ map fst dt++turtleChart :: Turtle -> [(Double, Double)] -> IO ()+turtleChart t ((x0, y0) : ps) = do+	penup t+	goto t x0 y0+	pendown t+	mapM_ (uncurry $ goto t) ps++getConverter :: (Enum x, Enum y) => (Double, Double) -> (Double, Double) ->+	[(x, y)] -> (x, y) -> (Double, Double)+getConverter (left, top) (width, height) ps = convertx *** converty+	where+	maxx = maximum $ map (fromEnum . fst) ps+	minx = minimum $ map (fromEnum . fst) ps+	maxy = maximum $ map (fromEnum . snd) ps+	miny = minimum $ map (fromEnum . snd) ps+	convertx x = left ++		(fromIntegral $ fromEnum x - minx) /+		(fromIntegral $ maxx - minx) * width+	converty y = top + height -+		(fromIntegral $ fromEnum y - miny) /+		(fromIntegral $ maxy - miny) * height