From 891e9f498b41d521225a28fe35d6b1a748187262 Mon Sep 17 00:00:00 2001 From: hashirama Date: Tue, 11 Nov 2025 18:43:15 +0000 Subject: [PATCH] final version takes a list of components, and generates the UI with it --- kanjiPicker.hs | 234 +++++++++++++++++++++++++++++++------------------ 1 file changed, 147 insertions(+), 87 deletions(-) diff --git a/kanjiPicker.hs b/kanjiPicker.hs index beab761..c212529 100644 --- a/kanjiPicker.hs +++ b/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