diff --git a/Identicon.hs b/Identicon.hs new file mode 100644 --- /dev/null +++ b/Identicon.hs @@ -0,0 +1,165 @@ +module Identicon where +import Control.Monad +import Data.List +import Graphics.Rendering.Cairo +import Text.Printf + +curry3 f a b c=f (a,b,c) +uncurry3 f (a,b,c)=f a b c + +defaultBlocks :: [Block] +defaultBlocks=nub $ concatMap expand + [Block [0,1,4,3] + ,Block [0,1,6] + ,Block [0,1,3] + ,Block [1,4,3] + ,Block [0,1,7,6] + ,Block [0,1,8,3] + ,Block [0,1,5,8,7,3] + ,Block [0,1,7,3] + ,Block [0,1,3,7,6,3] + -- ,Block [1,5,7,3] -- intentionally omitted for an aesthetic reason + ] + +defaultColors :: [Color] +defaultColors=map (\ix->hsvColor (fromIntegral ix/fromIntegral n) 0.45 1) [0..n-1] + where n=12 + + +test2 :: FilePath -> Identicon -> IO () +test2 path ident=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path + where r=do + scale (fromIntegral size) (fromIntegral size) + render ident + size=36 + +testAll :: IO () +testAll=mapM_ (\(ix,b)->test (printf "prim%03d.png" ix) b) $ zip ([1..] :: [Int]) defaultBlocks + +test :: FilePath -> Block -> IO () +test path block=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path + where r=do + scale (fromIntegral size) (fromIntegral size) + + setSourceRGB 0 0 0 + rectangle 0 0 1 1 + fill + + setSourceRGB 1 0 0 + renderBlock block + fill + size=32 + + +-- | Identicon instance +data Identicon=Identicon Color Block Block Block deriving(Show,Eq) + +numIdenticon :: Integer +numIdenticon=(fromIntegral $ length defaultBlocks)^3*(fromIntegral $ length defaultColors) + +mapIdenticon :: Integer -> Identicon +mapIdenticon x=Identicon (appC per) (appB corner) (appB edge) (appB mid) + where + appB=(defaultBlocks!!) + appC=(defaultColors!!) + + [per,corner,edge,mid]=decompose [m,n,n,n] x + n=length defaultBlocks + m=length defaultColors + +decompose :: [Int] -> Integer -> [Int] +decompose [] x=[] +decompose (b:bs) x=fromIntegral m:decompose bs q + where (q,m)=x `divMod` (fromIntegral b) + + +render :: Identicon -> Render () +render (Identicon per c e m)=do + setSourceColor $ RGB 1 1 1 + rectangle 0 0 1 1 + fill + + setSourceColor per + zipWithM_ renderB table ss + withinRegion 3 3 1 1 $ renderMid m + fill + where + renderB (x,y) block=withinRegion 3 3 x y $ renderBlock block + + ss=[r0 c,r0 e,r1 c + ,r3 e ,r1 e + ,r3 c,r2 e,r2 c] + + [r0,r1,r2,r3]=take 4 $ iterate (.rotateB) id + table=[(x,y)|y<-[0,1,2],x<-[0,1,2],x/=1||y/=1] + +renderMid m=mapM_ (uncurry renderB) $ zip [(0,0),(1,0),(1,1),(0,1)] $ take 4 $ iterate rotateB m + where renderB (x,y) block=withinRegion 2 2 x y $ renderBlock block + +withinRegion :: Int -> Int -> Int -> Int -> Render a -> Render a +withinRegion nx ny x y f=do + save + scale (1/fromIntegral nx) (1/fromIntegral ny) + translate (fromIntegral x) (fromIntegral y) + r<-f + restore + return r + + +-- | Unified color +data Color=RGB !Double !Double !Double deriving(Show,Eq) + +rgbColor,hsvColor :: Double -> Double -> Double -> Color +rgbColor r g b=RGB r g b +hsvColor h s v=case i `mod` 6 of + 0 -> RGB v t p + 1 -> RGB q v t + 2 -> RGB p v t + 3 -> RGB p q v + 4 -> RGB t p v + 5 -> RGB v p q + where + (i,f)=properFraction $ h*6 + + p=v*(1-s) + q=v*(1-s*f) + t=v*(1-s*(1-f)) + +setSourceColor :: Color -> Render () +setSourceColor (RGB r g b)=setSourceRGB r g b + +setSourceColorA :: Color -> Double -> Render () +setSourceColorA (RGB r g b) alpha=setSourceRGBA r g b alpha + + +-- | Primitive shape +-- points' locations are: +-- 0 1 2 +-- 3 4 5 +-- 6 7 8 +newtype Block=Block [Int] deriving(Show) + +-- | This is not complete. (ie:0,1,2 and 0,2) +instance Eq Block where + (Block xs) == (Block ys) + |length xs/=length ys = False + |otherwise = isInfixOf xs (ys++ys) || isInfixOf (reverse xs) (ys++ys) + +-- maximum of 8 patterns (rot:4 * rev:2) +expand :: Block -> [Block] +expand block=nub $ map ($block) syms + where + syms=rots++map (.reverseB) rots + rots=take 4 $ iterate (.rotateB) id + +renderBlock :: Block -> Render () +renderBlock (Block (x:xs))=do + uncurry moveTo (table!!x) + mapM_ (uncurry lineTo . (table!!)) xs + closePath + where table=[(0.5*fromIntegral x,0.5*fromIntegral y)|y<-[0,1,2],x<-[0,1,2]] + +rotateB (Block xs)=Block $ map ([2,5,8,1,4,7,0,3,6]!!) xs +reverseB (Block xs)=Block $ map ([2,1,0,5,4,3,8,7,6]!!) xs + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright © 2008-2012 Daiki Handa +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions + and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of the contributors may be used to + endorse or promote products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF +THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,344 @@ +module Main where +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Data.Binary hiding(get) +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as BS +import Data.Char +import Data.Digest.Pure.SHA +import Data.IORef +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ord +import Data.Word +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import System.Directory +import System.Environment +import System.Posix.Process +import System.Time +import System.FilePath.Posix + +import Identicon +import Debug.Trace + + +-- this is a command launcher intented to be used with xmonad. +-- nice replacement for gnome-panel when used with xmobar. +-- Don't do too much things. Shells/scripting languages are there for complex things. + +-- ***IMPLEMENTED*** +-- features: (refinement needed) +-- * command history depicted as identicon (thus no need to smuggle around with app icons, etc.) +-- * on-the-fly command ambiguous search +-- version alpha: only implements identicon and search + +-- ***IDEAS*** +-- it's good to have command common string are automatically given an identicon +-- show difference by highlighting and +-- drag'n'drop??? +-- one command may have multiple identicon. + + +-- | Needs configuration in xmonad.hs to always float this window in start-up. +main=do + home_path<-getEnv "HOME" + let histDir =joinPath [home_path,".Xec"] + histFile=joinPath [histDir,"history.dat"] + createDirectoryIfMissing True histDir + + initGUI + (query,poll,notify,finalize)<-beginSearch histFile + + -- this order is not arbitrary. can you guess the rule? + area <- drawingAreaNew + entry <- entryNew + box <- vBoxNew False 1 + boxPackStart box area PackGrow 0 + boxPackEnd box entry PackNatural 0 + window <- windowNew + set window [containerBorderWidth:=4,containerChild:=box] + windowSetDefaultSize window 250 450 + windowSetPosition window WinPosCenter + windowSetTitle window "Xec" + + result_local<-newIORef [] + waiting <-newIORef False -- Enter -> complete double-Enter -> exec anyway + + -- register event handlers + let handlePoll=do + yield + result<-poll + case result of + Just x -> writeIORef result_local x >> widgetQueueDraw area + Nothing -> return () + return True + handleExec=do -- single: complete + writeIORef waiting False + rs<-readIORef result_local + unless (null rs) $ set entry [entryText:=head rs] + return False + + timeoutAddFull handlePoll priorityDefaultIdle 50 + + onExpose area $ \Expose {} -> do + result<-readIORef result_local + (w,h) <-widgetGetSize area + dw <-widgetGetDrawWindow area + renderWithDrawable dw $ do + translate 0 (fromIntegral h) + drawCommands w result + return True + + let newQuery=do + text <-get entry entryText + (_,h)<-widgetGetSize area + query (1+h `div` commandHeight) text + + onEditableChanged entry newQuery + + onEntryActivate entry $ do + w<-readIORef waiting + if w + then do -- double: execute anyway + text<-get entry entryText + set entry [entryText:=""] + runMaybeT (execute text) >>= maybe (return ()) (\x->notify x >> mainQuit) + else do -- initiate + writeIORef waiting True + timeoutAddFull handleExec priorityDefaultIdle 350 + return () + + onDestroy window mainQuit + + -- show all widgets and enter main loop + widgetShowAll window + newQuery + mainGUI + + -- finalize searcher + finalize + + + + +-- | Monad Transformer for Maybe +data MaybeT m a=MaybeT {runMaybeT :: m (Maybe a)} + +instance Monad m => Monad (MaybeT m) where + return=MaybeT . return . Just + f >>= g=MaybeT $ runMaybeT f >>= maybe (return Nothing) (runMaybeT . g) + fail _=MaybeT $ return Nothing + +instance MonadTrans MaybeT where + lift f=MaybeT $ f >>= return . Just + +-- | Fail without an argument. +fail_ :: Monad m => m a +fail_=fail undefined + +-- | This can get ultra large. There should be no limit to number of entries. +-- data CommandLog=CommandLog deriving(Show) -- there's currently no need for this + +-- | Processed form of commands. Monoid. +data CommandHistory=CommandHistory (Map String CommandStat) +data CommandStat=CommandStat {lastInvoked :: ClockTime, timesInvoked :: Int} + +magic :: Word32 +magic=3141592653 + +instance Binary CommandHistory where + put (CommandHistory m)=put magic >> put m + get=do + x<-B.get + if x/=magic then error "Incorrectly formatted data found. Exiting." + else liftM CommandHistory B.get + +instance Binary CommandStat where + put (CommandStat x y)=put x >> put y + get=liftM2 CommandStat B.get B.get + +instance Binary ClockTime where + put (TOD secs picosecs)=put secs >> put picosecs + get=liftM2 TOD B.get B.get + +instance Monoid CommandHistory where + mempty=CommandHistory M.empty + mappend (CommandHistory m0) (CommandHistory m1)=CommandHistory $ M.unionWith merge m0 m1 + where merge s0 s1=CommandStat {lastInvoked =max (lastInvoked s0) (lastInvoked s1) + ,timesInvoked=timesInvoked s0+timesInvoked s1} + + +-- | Create CommandHistory of only one given command execution. +histSingleton :: String -> IO CommandHistory +histSingleton com=do + time<-getClockTime + return $ CommandHistory $ M.singleton com $ CommandStat {lastInvoked=time,timesInvoked=1} + + +-- | Score commands and return the best ones. +histSearch :: Int -> String -> ClockTime -> CommandHistory -> [String] +histSearch n q time (CommandHistory hist)=map fst $ take n $ reverse $ sortBy (comparing snd) pairs + where + pairs=catMaybes $ zipWith4 eval (M.keys hist) score_n score_d score_m + eval k n d m + |m<=0 = Nothing + |otherwise = Just (k,n+m+d) + -- + score_n=evalN $ M.elems hist + score_d=evalD time $ M.elems hist + score_m=evalM q $ M.keys hist + +-- | Score CommandStats in terms of total number of times of execution. +evalN :: [CommandStat] -> [Double] +evalN=map (log . (+1) . fromIntegral . timesInvoked) + +-- | Score CommandStats in terms of relative durations between last invocation. +evalD :: ClockTime -> [CommandStat] -> [Double] +evalD time ss=map f ds + where + f x=fromIntegral (1+minimum ds)/fromIntegral (1+x) + ds=map (getDurationInSeconds time . lastInvoked) ss + +-- | Most important. Score Commands in terms of mathing with the query. +-- Commands with 0 point should be removed from the result. +evalM :: String -> [String] -> [Double] +evalM k=map (\x->sum $ map (toI . isPrefixOf k) $ splitRedundant x) + where toI True =1 + toI False=0 + + +-- | Returns all possible words by separation. +splitRedundant :: String -> [String] +splitRedundant s=nub $ s:concatMap (flip looseSepBy s) " :_-/" + +looseSepBy :: Eq a => a -> [a] -> [[a]] +looseSepBy s xs=map reverse $ filter (not.null) $ aux xs [] + where + aux [] t=[t] + aux (x:xs) t + |x==s = t:aux xs [] + |x/=s = aux xs (x:t) + + +-- | Get duration between 2 ClotkTimes in exact seconds. +getDurationInSeconds :: ClockTime -> ClockTime -> Integer +getDurationInSeconds (TOD t1 _) (TOD t0 _)=t1-t0 + +stringToIdenticon :: String -> Identicon +stringToIdenticon=mapIdenticon . (flip mod numIdenticon) . integerDigest . sha256 . BS.pack . map (fromIntegral.ord) + + +commandMargin,commandSize,commandHeight :: Int +commandSize =24 +commandMargin=1 +commandHeight=commandSize+commandMargin*2 + +drawCommands :: Int -> [String] -> Render () +drawCommands width rs=zipWithM_ (\ix r->drawCommand width ix r $ ix==0) [0..] rs + +drawCommand :: Int -> Int -> String -> Bool -> Render () +drawCommand w i s compl=do + save + translate 0 $ fromIntegral (i*negate commandHeight) + + -- highlight + when compl $ do + setSourceRGBA 1 0.9 0.3 0.5 + rectangle 0 (fromIntegral $ negate commandHeight) (fromIntegral w) (fromIntegral commandHeight) + fill + + -- separator + setLineWidth 1 + setSourceRGB 0.3 0.3 0.35 + moveTo 0 0 + lineTo (fromIntegral w) 0 + stroke + + -- identicon + save + translate 0 $ negate $ fromIntegral $ commandSize+commandMargin + scale size size + Identicon.render $ stringToIdenticon s + restore + + -- text + selectFontFace "Monospace" FontSlantNormal FontWeightNormal + setFontSize $ 0.65*size + ext<-textExtents s + translate (fromIntegral $ commandSize+commandMargin) (0.5*(textExtentsHeight ext-(fromIntegral commandHeight))) + + setSourceRGB 0 0 0 + showText s + fill + + restore + where size=fromIntegral commandSize + + +-- | Return absolute path of the executable if it exists. +getExecutable :: String -> MaybeT IO FilePath +getExecutable name=do + ps<-lift getSearchPath + xs<-lift $ mapM (runMaybeT . check) $ reverse ps + MaybeT $ return $! selectMaybe xs + where check p=do + let path=joinPath [p,name] + x<-lift $ doesFileExist path + unless x fail_ + perm<-lift $ getPermissions path + unless (executable perm) fail_ + return path + +-- | execute given command in a separate process. +execute :: String -> MaybeT IO CommandHistory +execute command=do + exe<-getExecutable com + hist<-lift $ histSingleton $ unwords $ com:args + lift $ forkProcess $ executeFile exe False args Nothing + return hist + where (com:args)=words command + + +-- | Read CommandHistory from file and search asynchronously. This function returns immediately. +-- Returns (query,poll,notify,finialize). Returned actions are thread-safe. +beginSearch :: FilePath -> IO (Int->String->IO (),IO (Maybe [String]),CommandHistory->IO(),IO()) +beginSearch path=do + -- read history file strictly + exist<-doesFileExist path + let getHist|exist = BS.readFile path >>= return . decode . BS.reverse . BS.reverse + |otherwise = return mempty + hv<-getHist >>= newIORef + + qv<-newEmptyMVar + rv<-newEmptyMVar + + let loop x=do + q<-takeMVar qv + maybe (return ()) killThread x + s<-spawn q + loop $ Just s + spawn (n,q)=forkIO $ do + hist<-readIORef hv + time<-getClockTime + putMVar rv (histSearch n q time hist) + + forkIO $ loop Nothing + + let query n q=putMVar qv (n,q) + poll=tryTakeMVar rv + notify dh=readIORef hv >>= writeIORef hv . mappend dh + finalize=readIORef hv >>= encodeFile path + + return (query,poll,notify,finalize) + +selectMaybe :: [Maybe a] -> Maybe a +selectMaybe ms=case catMaybes ms of + [] -> Nothing + x:_ -> Just x + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Xec.cabal b/Xec.cabal new file mode 100644 --- /dev/null +++ b/Xec.cabal @@ -0,0 +1,22 @@ +name: Xec +version: 0.1.6 +synopsis: Gtk command launcher with identicon +description: + Xec (pron. exec) is a launcher with identicon. It's originally intended to be used with xmonad, + but you can use it anywhere gtk is available. Hit enter twice in a row to run the command as-is. + Hit enter once to complete the command with highlited one. +license: BSD3 +license-File: LICENSE +build-type: Simple +cabal-version: >=1.8 +category: Utils +maintainer: Daiki Handa (xanxys@gmail.com) +source-repository head + type: darcs + location: https://patch-tag.com/r/xanxys/Xec/ + +executable Xec + Build-Depends: base >=3 && <5, binary>=0.4, bytestring, gtk, cairo, filepath>=1.0, old-time, unix>=2.0, + directory, containers>=0.1, mtl, SHA + Main-Is: Main.hs + Other-Modules: Identicon