final version
takes a list of components, and generates the UI with it
This commit is contained in:
parent
8352bafe0d
commit
891e9f498b
1 changed files with 155 additions and 95 deletions
234
kanjiPicker.hs
234
kanjiPicker.hs
|
|
@ -21,117 +21,171 @@ import Graphics.X11.Xlib.Extras (xChangeProperty, propModeReplace)
|
|||
import Data.Char (chr, toUpper)
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.IORef
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
-- createKanjiPickerDialog: parent must be a Gtk.Window (ApplicationWindow is fine)
|
||||
createKanjiPickerDialog :: (Gtk.IsWindow parent) => parent -> IO Gtk.Dialog
|
||||
createKanjiPickerDialog parent = do
|
||||
-- components: full list of Text radicals (no keys bound)
|
||||
createKanjiPickerDialog :: Gtk.Window -> [T.Text] -> IO Gtk.Dialog
|
||||
createKanjiPickerDialog parent components = do
|
||||
dlg <- new Gtk.Dialog
|
||||
[ #transientFor := parent
|
||||
, #title := "Kanji Components"
|
||||
, #modal := True
|
||||
, #defaultWidth := 400
|
||||
, #defaultHeight := 300
|
||||
, #defaultWidth := 480
|
||||
, #defaultHeight := 320
|
||||
, #resizable := False
|
||||
, #decorated := True
|
||||
]
|
||||
|
||||
-- content area
|
||||
content <- Gtk.dialogGetContentArea dlg
|
||||
|
||||
-- selected display
|
||||
selected <- new Gtk.Label [ #label := "Selected: " ]
|
||||
-- UI top: pager controls and page label
|
||||
pagerBox <- new Gtk.Box [ #orientation := Gtk.OrientationHorizontal, #spacing := 8 ]
|
||||
prevBtn <- new Gtk.Button [ #label := "Prev" ]
|
||||
pageLbl <- new Gtk.Label [ #label := "" ]
|
||||
nextBtn <- new Gtk.Button [ #label := "Next" ]
|
||||
Gtk.boxAppend pagerBox prevBtn
|
||||
Gtk.boxAppend pagerBox pageLbl
|
||||
Gtk.boxAppend pagerBox nextBtn
|
||||
|
||||
-- the components with associated single-letter keys (use uppercase keys)
|
||||
let components :: [(T.Text, Char)]
|
||||
components =
|
||||
[ ("氵",'A'), ("心",'S'), ("亻",'D'), ("木",'F')
|
||||
, ("口",'G'), ("日",'H'), ("月",'J'), ("艹",'K')
|
||||
]
|
||||
-- area that will contain the dynamic grid (we will swap children)
|
||||
gridContainer <- new Gtk.Box [ #orientation := Gtk.OrientationVertical, #spacing := 6 ]
|
||||
|
||||
-- build a map key -> component for keyboard events
|
||||
let keyMap :: Map Char T.Text
|
||||
keyMap = Map.fromList [ (toUpper k, t) | (t,k) <- components ]
|
||||
-- selected label
|
||||
selected <- new Gtk.Label [ #label := "Selected:" ]
|
||||
|
||||
-- grid for tiles
|
||||
grid <- new Gtk.Grid [ #rowSpacing := 8, #columnSpacing := 8 ]
|
||||
-- available keys to zip with components on each page
|
||||
let keys :: [Char]
|
||||
keys = "ASDFGHJKLQWERTYUIOPZXCVBNM" -- change order / letters as you like
|
||||
|
||||
-- helper to append to selected label
|
||||
pageSize = length keys
|
||||
|
||||
totalPages = (length components + pageSize - 1) `div` pageSize
|
||||
|
||||
-- state
|
||||
pageRef <- newIORef (0 :: Int)
|
||||
keyMapRef <- newIORef (Map.empty :: Map Char T.Text)
|
||||
btnMapRef <- newIORef (Map.empty :: Map Char Gtk.Button)
|
||||
gridRef <- newIORef (Nothing :: Maybe Gtk.Widget)
|
||||
|
||||
-- append controls to dialog
|
||||
Gtk.boxAppend content pagerBox
|
||||
Gtk.boxAppend content gridContainer
|
||||
Gtk.boxAppend content selected
|
||||
|
||||
-- appendSelected appends into the selected label (shared by clicks & keys)
|
||||
let appendSelected txt = do
|
||||
old <- Gtk.labelGetText selected
|
||||
let newt = if T.null old || old == "Selected:" then ("Selected: " <> txt)
|
||||
else (old <> " " <> txt)
|
||||
Gtk.labelSetText selected newt
|
||||
let stripped = T.strip old
|
||||
base = if stripped == "Selected:" then "" else T.drop (T.length "Selected: " ) stripped
|
||||
newt = if T.null base then txt else base <> " " <> txt
|
||||
Gtk.labelSetText selected ("Selected: " <> newt)
|
||||
|
||||
-- create tile: button with overlayed small key label bottom-right
|
||||
forM_ (zip [0..] components) $ \(i, (kanji, key)) -> do
|
||||
-- big button that shows the kanji centered
|
||||
btn <- new Gtk.Button [ #hexpand := True, #vexpand := True ]
|
||||
-- put the kanji label as child of the button so it centers nicely
|
||||
kanjiLbl <- new Gtk.Label
|
||||
[ #label := kanji
|
||||
, #marginTop := 8
|
||||
, #marginBottom := 8
|
||||
, #marginStart := 8
|
||||
, #marginEnd := 8
|
||||
, #halign := Gtk.AlignCenter
|
||||
, #valign := Gtk.AlignCenter
|
||||
]
|
||||
-- build a page grid for given page index and set key/button maps
|
||||
let buildPage :: Int -> IO Gtk.Grid
|
||||
buildPage p = do
|
||||
let start = p * pageSize
|
||||
pageItems = take pageSize (drop start components)
|
||||
pairs = zip keys pageItems -- dynamic zip: keys -> components on this page
|
||||
|
||||
#setChild btn (Just kanjiLbl)
|
||||
grid <- new Gtk.Grid [ #rowSpacing := 8, #columnSpacing := 8 ]
|
||||
|
||||
-- overlay: main child (button) + overlay small key label
|
||||
overlay <- new Gtk.Overlay []
|
||||
Gtk.overlaySetChild overlay (Just btn)
|
||||
-- reset maps for this page
|
||||
let emptyKeyMap = Map.empty :: Map Char T.Text
|
||||
writeIORef keyMapRef emptyKeyMap
|
||||
writeIORef btnMapRef Map.empty
|
||||
|
||||
keyLbl <- new Gtk.Label [ #label := T.singleton (toUpper key) ]
|
||||
-- align key label to bottom-right and add small margin so it doesn't cover the glyph
|
||||
#setHalign keyLbl Gtk.AlignEnd
|
||||
#setValign keyLbl Gtk.AlignEnd
|
||||
#setMarginEnd keyLbl 6
|
||||
#setMarginBottom keyLbl 4
|
||||
-- optionally style smaller
|
||||
-- via CSS class or smaller font: use markup or set style context
|
||||
ctx <- Gtk.widgetGetStyleContext keyLbl
|
||||
Gtk.styleContextAddClass ctx "small-key"
|
||||
forM_ (zip [0..] pairs) $ \(i, (k, comp)) -> do
|
||||
-- button with centered label for the kanji
|
||||
btn <- new Gtk.Button [ #hexpand := True, #vexpand := True ]
|
||||
lbl <- new Gtk.Label [ #label := comp ]
|
||||
Gtk.widgetSetHalign lbl Gtk.AlignCenter
|
||||
Gtk.widgetSetValign lbl Gtk.AlignCenter
|
||||
#setChild btn (Just lbl)
|
||||
|
||||
-- small key label in the corner (Overlay)
|
||||
overlay <- new Gtk.Overlay []
|
||||
Gtk.overlaySetChild overlay (Just btn)
|
||||
|
||||
Gtk.overlayAddOverlay overlay keyLbl
|
||||
keyLbl <- new Gtk.Label [ #label := T.singleton (toUpper k) ]
|
||||
Gtk.widgetSetHalign keyLbl Gtk.AlignEnd
|
||||
Gtk.widgetSetValign keyLbl Gtk.AlignEnd
|
||||
Gtk.widgetSetMarginEnd keyLbl 6
|
||||
Gtk.widgetSetMarginBottom keyLbl 4
|
||||
sc <- Gtk.widgetGetStyleContext keyLbl
|
||||
Gtk.styleContextAddClass sc "small-key"
|
||||
Gtk.overlayAddOverlay overlay keyLbl
|
||||
|
||||
-- clicking the button appends the component
|
||||
void $ on btn #clicked $ appendSelected kanji
|
||||
-- click action should append the component
|
||||
void $ Gtk.on btn #clicked $ appendSelected comp
|
||||
|
||||
-- attach overlay into grid
|
||||
let cols = 4
|
||||
col = fromIntegral (i `mod` cols)
|
||||
row = fromIntegral (i `div` cols)
|
||||
Gtk.gridAttach grid overlay col row 1 1
|
||||
-- put overlay into grid
|
||||
let cols = 8 :: Int -- visual columns (tweak to taste)
|
||||
col = fromIntegral (i `mod` cols)
|
||||
row = fromIntegral (i `div` cols)
|
||||
Gtk.gridAttach grid overlay col row 1 1
|
||||
|
||||
-- keyboard handling: controller on the dialog
|
||||
-- keyboard handling: pressing a key activates its kanji
|
||||
-- update maps
|
||||
modifyIORef' keyMapRef (Map.insert (toUpper k) comp)
|
||||
modifyIORef' btnMapRef (Map.insert (toUpper k) btn)
|
||||
|
||||
return grid
|
||||
|
||||
-- helper to render current page: remove old grid, create new one and show
|
||||
renderPage :: IO ()
|
||||
renderPage = do
|
||||
p <- readIORef pageRef
|
||||
let lblText = "Page " <> T.pack (show (p+1)) <> " / " <> T.pack (show totalPages)
|
||||
Gtk.labelSetText pageLbl lblText
|
||||
|
||||
-- remove old grid if any
|
||||
mOld <- readIORef gridRef
|
||||
case mOld of
|
||||
Just w -> void $ Gtk.boxRemove gridContainer w
|
||||
Nothing -> pure ()
|
||||
|
||||
-- build and append new grid
|
||||
g <- buildPage p
|
||||
wg <- Gtk.toWidget g
|
||||
writeIORef gridRef (Just wg)
|
||||
Gtk.boxAppend gridContainer g
|
||||
-- ensure visible
|
||||
Gtk.widgetShow g
|
||||
|
||||
-- Prev / Next handlers
|
||||
void $ Gtk.on prevBtn #clicked $ do
|
||||
modifyIORef' pageRef (\x -> max 0 (x - 1))
|
||||
renderPage
|
||||
|
||||
void $ Gtk.on nextBtn #clicked $ do
|
||||
modifyIORef' pageRef (\x -> min (totalPages - 1) (x + 1))
|
||||
renderPage
|
||||
|
||||
-- keyboard controller: left/right pages and per-page keys
|
||||
keyController <- Gtk.eventControllerKeyNew
|
||||
Gtk.widgetAddController dlg keyController
|
||||
|
||||
on keyController #keyPressed $ \keyval _keycode _state -> do
|
||||
let ch = fromIntegral keyval
|
||||
if ch == 0
|
||||
void $ Gtk.on keyController #keyPressed $ \keyval _keycode _state -> do
|
||||
u <- Gdk.keyvalToUnicode keyval
|
||||
if u == 0
|
||||
then return False
|
||||
else do
|
||||
let uc = toUpper (chr ch)
|
||||
case Map.lookup uc keyMap of
|
||||
Just kanji -> do
|
||||
appendSelected kanji
|
||||
putStrLn $ "Activated component: " ++ T.unpack kanji
|
||||
return True
|
||||
Nothing -> return False
|
||||
let ch = toUpper (chr (fromIntegral u))
|
||||
case ch of
|
||||
'\x2190' -> do -- left arrow (not reliable via unicode here)
|
||||
modifyIORef' pageRef (\x -> max 0 (x - 1)); renderPage; return True
|
||||
'\x2192' -> do -- right arrow
|
||||
modifyIORef' pageRef (\x -> min (totalPages - 1) (x + 1)); renderPage; return True
|
||||
_ -> do
|
||||
km <- readIORef keyMapRef
|
||||
case Map.lookup ch km of
|
||||
Just comp -> appendSelected comp >> return True
|
||||
Nothing -> return False
|
||||
|
||||
-- add the key controller to the dialog's widget
|
||||
-- attach controller to dialog
|
||||
Gtk.widgetAddController dlg keyController
|
||||
|
||||
-- pack grid and selected label into content area
|
||||
Gtk.boxAppend content grid
|
||||
Gtk.boxAppend content selected
|
||||
-- initial render
|
||||
renderPage
|
||||
|
||||
return dlg
|
||||
|
||||
|
|
@ -178,10 +232,11 @@ attachDialogOnRealize win = do
|
|||
on wnd #realize (setWindowAsDialog win)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- new Gtk.Application [#applicationId := "org.example.test"]
|
||||
|
||||
on app #activate $ do
|
||||
void $ Gtk.on app #activate $ do
|
||||
win <- new Gtk.ApplicationWindow
|
||||
[ #application := app
|
||||
, #title := "Main Window"
|
||||
|
|
@ -189,16 +244,21 @@ main = do
|
|||
, #defaultHeight := 100
|
||||
]
|
||||
|
||||
-- List of all kanji components (you can extend freely)
|
||||
let allComponents :: [T.Text]
|
||||
allComponents =
|
||||
[ "氵", "心", "亻", "木", "口", "日", "月", "艹"
|
||||
, "火", "女", "糸", "手", "金", "水", "土", "言"
|
||||
, "目", "耳", "足", "見", "虫", "貝", "車", "食"
|
||||
, "魚", "鳥", "雨", "馬", "風", "竹", "田", "米"
|
||||
, "石", "山", "川", "弓", "矢", "刀", "犬", "王"
|
||||
]
|
||||
|
||||
parentWin <- Gtk.toWindow win
|
||||
dlg <- createKanjiPickerDialog parentWin
|
||||
dlg <- createKanjiPickerDialog parentWin allComponents
|
||||
|
||||
|
||||
void $ mainContextInvokeFull Nothing (-99) $ do
|
||||
_ <- attachDialogOnRealize dlg
|
||||
return False
|
||||
|
||||
#realize dlg
|
||||
Gtk.widgetShow dlg
|
||||
-- Show both main window and dialog
|
||||
Gtk.widgetShow win
|
||||
Gtk.widgetShow dlg
|
||||
|
||||
void $ applicationRun app Nothing
|
||||
|
|
|
|||
Loading…
Reference in a new issue