画像ビューアー

	import Graphics.UI.Gtk as G
	main = do
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 500, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	b <- buttonNew
	i <- imageNewFromFile "IMGP2850.JPG"
	buttonSetImage b i
	containerAdd hb b
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw view.hs hosted with ❤ by GitHub

---

この画像（IMGP2850.JPG）を表示します。

ただこのやり方だと元画像の大きさそのままで表示されます。
サイズを変更して表示するには一旦Pixbufのインスタンスをつくってから
Buttonに貼り付けます。

	import Graphics.UI.Gtk as G
	main = do
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 500, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	b <- buttonNew
	p <- pixbufNewFromFileAtSize "IMGP2850.JPG" 64 64
	i <- imageNewFromPixbuf p
	b `set` [buttonImage := i]
	containerAdd hb b
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw view2.hs hosted with ❤ by GitHub

---

かんたんな画像のビューアーをつくります。 まずディレクトリーを選択するダイアログ。

	import Graphics.UI.Gtk
	main = do
	initGUI
	fchdal <- fileChooserDialogNew Nothing Nothing
	FileChooserActionSelectFolder
	[("Cancel", ResponseCancel), ("Select", ResponseAccept)]
	fchdal `set` [fileChooserDoOverwriteConfirmation := True]
	widgetShow fchdal
	response <- dialogRun fchdal
	case response of
	ResponseCancel -> putStrLn "You cancelled..."
	ResponseAccept -> do
	nwf <- fileChooserGetFilename fchdal
	case nwf of
	Nothing -> putStrLn "Nothing"
	Just path -> putStrLn path
	w <- windowNew
	w `set` [windowDefaultWidth := 16, windowDefaultHeight := 16]
	s <- spinnerNew
	containerAdd w s
	widgetShowAll w
	spinnerStart s
	widgetDestroy fchdal
	fchdal `on` objectDestroy $ mainQuit
	mainGUI

view raw dirchooser.hs hosted with ❤ by GitHub

---

dirというファイルにリダイレクトしておきます。

$ runghc dirchooser.hs > dir

---

ビューアー

---

	import System.FilePath.Posix
	import Graphics.UI.Gtk
	import System.Directory
	import Control.Monad
	import System.FilePath.Posix
	newPixBufs size = mapM (\fn -> pixbufNewFromFileAtSize fn size size)
	dirFile = "dir"
	getD = readFile dirFile >>= (return . head . lines)
	isJpg fn = ex == ".jpg" || ex == ".JPG" where ex = takeExtension fn
	getJpegFiles0 = do
	getD >>= getDirectoryContents >>= filterM (return . isJpg)
	getJpegFiles = do
	getJpegFiles0 >>= mapM (\x -> do {d <- getD;return (d++"/"++x)})
	newImgButton size f f' = do
	vb <- vBoxNew True 0
	p <- pixbufNewFromFileAtSize f size size
	i <- imageNewFromPixbuf p
	b <- buttonNew
	set b [buttonImage := i]
	l <- labelNew $ Just $ f' ++ " "
	containerAdd vb b
	containerAdd vb l
	return vb
	newImgButtons :: Int ->[FilePath] -> [FilePath]-> IO [VBox]
	newImgButtons size fs fs' = do
	bs <- zipWithM (\x y -> newImgButton size x y) fs fs'
	return bs
	main = do
	files <- getJpegFiles
	files' <- getJpegFiles0
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 1000, windowDefaultHeight := 150]
	hb <- hBoxNew False 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	bs <- newImgButtons 64 files files'
	mapM_ (containerAdd hb) bs
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw viewer.hs hosted with ❤ by GitHub

ただ表示するだけではあまりにも芸がないのでちょっとした操作をしてみます。

ソースコード

https://github.com/index333/image

---

まず補助的関数を集めたMyImageモジュール

	module MyImage where
	import System.Exit
	import System.FilePath.Posix
	import Graphics.UI.Gtk
	import System.Directory
	import Control.Monad
	dirFile = "dir"
	getD = readFile dirFile >>= (return . head . lines)
	isJpg fn = ex == ".jpg" || ex == ".JPG"
	where ex = takeExtension fn
	getJpegFiles0 = do
	getD
	>>=
	getDirectoryContents
	>>=
	filterM (return . isJpg)
	getJpegFiles = do
	getJpegFiles0
	>>=
	(\x -> if null x
	then do print " No Jpg file in this directory."
	exitWith ExitSuccess
	return x
	else return x)
	>>=
	mapM (\x -> do {d <- getD;return (d++"/"++x)})
	viewButtons pvs blist = zipWithM viewButton pvs $ map b2c $ pac4 blist
	viewButton' pv rotation = do
	b <- buttonNew
	pv' <- pixbufRotateSimple pv rotation
	i <- imageNewFromPixbuf pv'
	set b [buttonImage := i]
	return b
	viewButton pv "right" = viewButton' pv PixbufRotateClockwise
	viewButton pv "left" = viewButton' pv PixbufRotateCounterclockwise
	viewButton pv "updown" = viewButton' pv PixbufRotateUpsidedown
	viewButton pv _ = viewButton' pv PixbufRotateNone
	newPixBufs size = mapM (\fn -> pixbufNewFromFileAtSize fn size size)
	newImgButton p = do
	b <- buttonNew
	i <- imageNewFromPixbuf p
	set b [buttonImage := i]
	return b
	newImgButtons :: [Pixbuf] -> IO [Button]
	newImgButtons = mapM newImgButton
	newRadioButton c n = do
	b <- radioButtonNew
	p <- pixbufNewFromFileAtSize (c ++ ".png") 32 32
	i <- imageNewFromPixbuf p
	set b [buttonImage := i]
	return b
	newRadioButtons i = do
	bb@(b:bs) <- mapM (\x -> newRadioButton x i) ["keep","right","left","updown"]
	mapM_ (\x -> x `set` [radioButtonGroup := b]) bs
	return bb
	b2c :: [Bool] -> String
	b2c [True,False,False,False] = "keep"
	b2c [False,True,False,False] = "right"
	b2c [False,False,True,False] = "left"
	b2c [False,False,False,True ]= "updown"
	pac' _ [] l = reverse l
	pac' i l ll = pac' i (drop i l) (take i l : ll)
	pac i l = pac' i l []
	pac4 = pac 4
	toBoollist :: String -> [Bool]
	toBoollist = read

view raw MyImage.hs hosted with ❤ by GitHub

---

一括処理を選択します。

---

	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	newSelectButton label box = do
	b <- buttonNewWithLabel label
	b `on` buttonActivated $ func1 b
	containerAdd box b
	return b
	newSelectButtons labels box = do
	mapM ((flip newSelectButton) box) labels
	func1 b = do
	b `get` buttonLabel
	>>=
	putStrLn
	>>
	mainQuit
	main = do
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 1000, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	vb <- vBoxNew True 0
	let selections = [ "Right All",
	"Left All",
	"Right-Left",
	"Left-Right",
	"UpDown All",
	"Up-Down",
	"Down-Up",
	"NO Pattern" ]
	newSelectButtons selections hb
	containerAdd vb hb
	ps <- newPixBufs 50 fl
	bs <- newImgButtons ps
	zipWithM (\x y -> set x [buttonLabel := (show y)]) bs [0..(length fl - 1)]
	hb1 <- hBoxNew False 0
	mapM (containerAdd hb1) bs
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb1
	containerAdd vb sw
	containerAdd w vb
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw select.hs hosted with ❤ by GitHub

---

画像の回転指定

---

	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	main = do
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w [windowTitle := "Close this window, to go to the next step.",
	windowWindowPosition := WinPosCenter,
	windowDefaultWidth := (length fl * 100),
	windowDefaultHeight := 400]
	sw <- scrolledWindowNew Nothing Nothing
	hb <- hBoxNew True 0
	vb0 <- vBoxNew True 0
	pbs <- newPixBufs 50 fl
	pbs1 <- newPixBufs (size fl) fl
	ibs <- newImgButtons pbs
	rbs <- mapM newRadioButtons [0..(length fl - 1)]
	mapM_ (\x -> (x `on` buttonActivated)(update pbs1 (concat rbs))) (concat rbs)
	c <- getContents
	let c' = lines c
	if null c' then setActive "No Pattern" rbs else setActive (head c') rbs
	zipWithM (\x y -> do
	f <- frameNew
	vb <- vBoxNew True 0
	containerAdd f vb
	boxPackStart vb x PackNatural 0
	mapM_ (\z -> boxPackStart vb z PackNatural 0) y
	boxPackStart hb f PackNatural 0)
	ibs rbs
	boxPackStart vb0 hb PackNatural 0
	scrolledWindowAddWithViewport sw vb0
	containerAdd w sw
	widgetShowAll w
	w `on` unrealize $ end $ concat rbs
	mainGUI
	size fl | length fl < 15 = 50
	| otherwise = round $ 50 / d
	where len = fromIntegral $ length fl
	d = len / 15
	setActive' bs l =
	zipWithM(\x y->((x!!y) `set` [toggleButtonActive := True])) bs $ cycle l
	setActive "Right All" bs = setActive' bs [1]
	setActive "Left All" bs = setActive' bs [2]
	setActive "UpDown All" bs = setActive' bs [3]
	setActive "Right-Left" bs = setActive' bs [1,2]
	setActive "Left-Right" bs = setActive' bs [2,1]
	setActive "Up-Down" bs = setActive' bs [0,3]
	setActive "Down-Up" bs = setActive' bs [3,0]
	setActive _ bs = setActive' bs [0]
	update pbs rbs = do
	w <- windowNewPopup
	w `set` [windowDefaultWidth := width, windowDefaultHeight := 150]
	hb <- hBoxNew True 0
	hb1 <- hBoxNew True 0
	vb <- vBoxNew True 0
	label <- labelNew $ Just "Show modified pictures"
	boxPackStart hb label PackNatural 0
	l <- mapM ((flip get)toggleButtonActive) rbs
	vbs <- viewButtons pbs l
	mapM_ (\x -> boxPackStart hb1 x PackNatural 0) vbs
	mapM_ (\x -> boxPackStart vb x PackNatural 0) [hb,hb1]
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw vb
	containerAdd w sw
	widgetShowAll w
	where width | length pbs * 100 > 1000 = 1050
	| otherwise = length pbs * 100
	end rbs = do
	mapM ((flip get) toggleButtonActive) rbs
	>>=
	print
	>>
	mainQuit

view raw image.hs hosted with ❤ by GitHub

---

確認

---

	import MyTable
	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	main = do
	c <- getContents
	let l = pac4 (toBoollist c)
	let coms = map b2c l
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w[windowTitle := "Confirm window",
	windowWindowPosition := WinPosCenter,
	windowDefaultWidth := (length fl*100),
	windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	hb1 <- hBoxNew True 0
	vb <- vBoxNew True 0
	let txt = "Close this window,to go to the next step.\n" ++
	"Modified pictures are in the upper row.\n" ++
	"Original pictures are in the lower row."
	l0 <- labelNew $ Just txt
	ps <- newPixBufs 50 fl
	bs <- newImgButtons ps
	zipWithM (\x y -> x `set` [buttonLabel := (show y)]) bs [0..(length fl - 1)]
	vbs <- zipWithM (viewButton) ps coms
	t <- mkTable [vbs, bs] (2::Row) ((length bs)::Col)
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw t
	boxPackStart hb l0 PackNatural 0
	boxPackStart vb hb PackNatural 0
	containerAdd vb sw
	containerAdd w vb
	widgetShowAll w
	w `on` unrealize $ mainQuit >> putStrLn c
	mainGUI

view raw confirm.hs hosted with ❤ by GitHub

---

MyTable モジュール

	module MyTable where
	import Graphics.UI.Gtk
	import Control.Monad
	type Row = Int
	type Col = Int
	mkTable :: (Foldable t, WidgetClass widget) => t [widget] -> Row -> Col -> IO Table
	mkTable ws rs cs = do
	t <- tableNew rs cs True
	zipWithM (\x (a,b,c,d)-> tableAttachDefaults t x a b c d)
	(concat ws)
	(mkPos rs cs)
	return t
	mkPos r c = let rc = cross r c in
	map (\(x,y) -> (y,y+1,x,x+1)) rc
	cross r c = [(a,b)|a <- [0..(r-1)],b <- [0..(c-1)]]

view raw MyTable.hs hosted with ❤ by GitHub

---

最後にConvertコマンドを実行します。

---

	import System.Process
	import System.Exit
	import Graphics.UI.Gtk
	import MyImage
	mkopt' dig f = ["-verbose","-rotate",dig,f,f]
	mkopt'' dig f = ["-rotate",dig,f]
	mkopt fu ("right",f) = fu "90" f
	mkopt fu ("left",f) = fu "-90" f
	mkopt fu ("updown",f) = fu "180" f
	mkopt _ _ = [] -- mkopt' "0" f
	disp coms = do
	fs0 <- getJpegFiles0
	let ops' = filter (\x -> null x == False)
	$ zipWith (\x y -> mkopt mkopt'' (x, y)) coms fs0
	mapM_ (\x -> do
	mapM_ (\y -> do {putStr y; putStr " "}) x
	putStrLn "")
	ops'
	main = do
	c <- getContents
	let l = pac4 (toBoollist c)
	fs <- getJpegFiles
	let coms = map b2c l
	let ops = filter (\x -> null x == False)
	$ zipWith (\x y -> mkopt mkopt' (x, y)) coms fs
	if null ops
	then exitWith ExitSuccess >> return ()
	else return ()
	disp coms
	initGUI
	dia <- dialogNew
	dialogAddButton dia stockApply ResponseApply
	dialogAddButton dia stockCancel ResponseCancel
	label <- labelNew (Just "Exec 'convert' command with these options?")
	upbox <- dialogGetUpper dia
	boxPackStart upbox label PackGrow 10
	widgetShowAll upbox
	answer <- dialogRun dia
	if answer == ResponseApply
	then do {mapM_ (rawSystem "convert") ops; return ()}
	else widgetDestroy dia
	dia `on` unrealize $ mainQuit

view raw mkCom.hs hosted with ❤ by GitHub

---

スクリプトは

runghc dirChooser.hs > dir
runghc select.hs > tmp
cat tmp | runghc image.hs > tmp1
cat tmp1 | runghc confirm.hs > tmp2
cat tmp2 | runghc mkCom.hs

アイコンが必要です。

keep.png  left.png  right.png  updown.png