Add scrollableDictionaryIconBar.hs

scrollableDictionaryIconBar.hs

@@ -0,0 +1,246 @@
+{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-}
+-- Copyright © 2025 Hashirama Senju
+
+import System.Clock   -- To measure time
+import System.Console.ANSI  -- For colored output
+--
+import Z.Data.CBytes (pack, unpack)
+import Z.IO.FileSystem (scandirRecursively)
+import System.FilePath (takeDirectory, dropExtension, takeExtension)
+import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find)
+import System.IO
+import qualified Data.Map as Map
+import Control.Concurrent.Async (mapConcurrently)
+import Control.Concurrent 
+import Control.Monad
+import Data.Char (isSpace)
+import Data.Maybe (mapMaybe, maybeToList)
+
+
+import qualified GI.Gtk as Gtk
+import GI.Gtk (Grid(..), Image(..), Orientable(..))
+import GI.Gio
+import Control.Monad (void)
+import qualified Data.Text as T
+
+
+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified GI.Gtk as Gtk
+import GI.Gtk (AttrOp((:=)))
+import Data.Text (Text)
+import qualified Data.Text as T
+
+createIconToolbar' :: [FilePath] -> IO Gtk.Box
+createIconToolbar' iconPaths = do
+    toolbar <- Gtk.boxNew Gtk.OrientationHorizontal 0
+    Gtk.widgetSetHalign toolbar Gtk.AlignCenter
+    Gtk.widgetSetValign toolbar Gtk.AlignCenter
+    
+    mapM_ (\path -> do
+        icon <- Gtk.imageNewFromFile path
+        Gtk.widgetSetSizeRequest icon 64 64  -- Force minimum size
+
+        btn <- Gtk.buttonNew
+        Gtk.widgetSetSizeRequest btn 80 80   -- Button size (icon + padding)
+        Gtk.widgetSetHalign btn Gtk.AlignCenter
+        Gtk.widgetSetValign btn Gtk.AlignCenter
+        Gtk.buttonSetChild btn (Just icon)
+        
+        -- Add click handler
+        void $ Gtk.on btn #clicked $ do
+            putStrLn $ "Selected: " ++ path
+            -- Add your click handler logic here
+            
+        Gtk.boxAppend toolbar btn
+        ) iconPaths
+    
+    return toolbar
+
+-- Wrap the toolbar in a ScrolledWindow that scrolls horizontally
+createIconToolbar :: [FilePath] -> IO Gtk.Widget
+createIconToolbar iconPaths = do
+    -- Get your original toolbar (horizontal box)
+    toolbar <- createIconToolbar' iconPaths
+    
+    -- Create a new scrolled window
+    scrolled <- Gtk.scrolledWindowNew
+    
+    -- Show the horizontal scrollbar automatically, never show the vertical one
+    Gtk.scrolledWindowSetPolicy scrolled Gtk.PolicyTypeAutomatic Gtk.PolicyTypeNever
+
+    -- Put the horizontal box (your toolbar) inside the scrolled window
+    Gtk.scrolledWindowSetChild scrolled (Just toolbar)
+    
+    -- Return as a general Widget
+    Gtk.toWidget scrolled
+
+---
+
+type FileList = [(String, [String])]  -- (Directory, Files)
+
+extractIcons :: FileList -> [String]  -- List of icon paths
+extractIcons = concatMap processGroup
+  where
+    processGroup (_, files) = maybeToList (findIcon files)
+
+findIcon :: [String] -> Maybe String
+findIcon files = do
+    mdxFile <- find isMdxFile files
+    let baseName = dropExtension mdxFile
+    find (isIconFile baseName) files
+  where
+    isMdxFile file = takeExtension file == ".mdx"
+    isIconFile base file = 
+        dropExtension file == base && 
+        takeExtension file `elem` imageExtensions
+
+imageExtensions :: [String]
+imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"]
+
+
+
+-- Derived version with automatic string handling
+scanDirectoryRecursivelyStr :: String -> IO [String]
+scanDirectoryRecursivelyStr path = do
+    result <- scandirRecursively (pack path) (\p _ -> return True)
+    return (map unpack result)  -- Ensures all results are decoded to Strings (UTF-8)
+
+-- Function to filter files with a specific extension
+filterMdx :: [String] -> String -> [String]
+filterMdx files ext = filter (isSuffixOf ext) files
+
+-- Custom implementation of takeDirectory for UTF-8 strings
+takeDirectory' :: String -> String
+takeDirectory' path = reverse . dropWhile (/= '/') . reverse $ path
+
+data FileGroup = FileGroup
+  { directory :: String   -- The directory part of the file path (UTF-8 String)
+  , files     :: [String] -- List of file paths in that directory (UTF-8 Strings)
+  } deriving (Show, Eq)
+
+-- Create a map from directory to list of .mdx files
+groupMdxByDirectory :: [String] -> Map.Map String [String]
+groupMdxByDirectory mdxFiles = 
+  Map.fromListWith (++) [(takeDirectory' file, [file]) | file <- mdxFiles]
+
+-- Group files by their directory, including additional files that belong to the same directory
+groupFilesByDirectory :: [String] -> [String] -> IO [FileGroup]
+groupFilesByDirectory mdxFiles additionalFiles = do
+  -- Create a map of directories to .mdx files
+  let mdxMap = groupMdxByDirectory mdxFiles
+  
+  -- Function to process each directory group in parallel
+  let processGroup dir mdxFilesInDir = do
+        let -- Filter additional files that belong to the same directory
+            additionalFilesInDir = filter (\f -> takeDirectory' f == dir) additionalFiles
+            -- Remove matching files from additional files (those that are already in the .mdx list)
+            remainingAdditionalFiles = filter (\f -> not (f `elem` mdxFilesInDir)) additionalFilesInDir
+            -- Combine and remove duplicates
+            allFiles = nub (mdxFilesInDir ++ remainingAdditionalFiles)
+        return $ FileGroup dir allFiles
+
+  -- Process each directory group concurrently
+  groupedFiles <- mapConcurrently (\(dir, mdxFilesInDir) -> processGroup dir mdxFilesInDir) (Map.toList mdxMap)
+  return groupedFiles
+  
+-- Function to convert FileGroup to a string representation for file output
+fileGroupToString :: FileGroup -> String
+fileGroupToString (FileGroup dir files) = 
+    "Directory: " ++ dir ++ "\n" ++
+    unlines (map ("  " ++) files)
+
+
+-- Box-like animation function with green color
+boxAnimation :: IO ()
+boxAnimation = do
+    let frames = ["[   ]", "[.  ]", "[ . ]", "[  .]"]  -- Frame progression for box
+    let loop frames' = do
+          mapM_ (\frame -> do
+            setSGR [SetColor Foreground Vivid Green]  -- Set the box color to green
+            putStr "\r"  -- Move cursor to the start of the line
+            putStr frame  -- Print the current frame
+            hFlush stdout  -- Flush output buffer
+            threadDelay 200000) frames'  -- Wait 0.2 seconds between frames
+          loop frames'  -- Recursively call to keep the loop running
+    loop frames  -- Start the looping animation
+
+
+
+-- A simple trim function to remove leading/trailing whitespace
+trim :: String -> String
+trim = f . f
+  where f = reverse . dropWhile isSpace
+
+-- Process lines to produce a list of (directory, [file paths]) tuples.
+-- It ignores lines until the first "Directory:" is found (and discards it),
+-- then uses subsequent "Directory:" lines to start new groups.
+processLines :: [String] -> [(String, [String])]
+processLines = reverse . go False []
+  where
+    -- The Bool flag indicates whether we've encountered the first "Directory:" line.
+    go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])]
+    go _ acc [] = acc
+    -- Before the first "Directory:" has been seen:
+    go False acc (line:rest)
+      | "Directory:" `isPrefixOf` line = go True acc rest  -- Skip first occurrence.
+      | otherwise = go False acc rest
+    -- After the first "Directory:" has been skipped, but before starting any group:
+    go True [] (line:rest)
+      | "Directory:" `isPrefixOf` line =
+          let dir = trim (drop 11 line)
+          in go True [(dir, [])] rest
+      | otherwise = go True [] rest  -- Ignore non-directory lines until the second occurrence.
+    -- When a group has been started:
+    go True ((currentDir, files):xs) (line:rest)
+      | "Directory:" `isPrefixOf` line =
+          let dir = trim (drop 11 line)
+          in go True ((dir, []):(currentDir, files):xs) rest
+      | otherwise =
+          go True ((currentDir, files ++ [trim line]) : xs) rest
+
+
+{-
+this should be used that way:
+
+     result <- getData "output.txt"
+     let finalresult = processLines result   -- that way we maintain purity
+-}
+
+getData :: FilePath -> IO [String]
+getData f = do 
+    content <- readFile f
+    return (lines content)
+
+
+
+main :: IO ()
+main = do
+    -- Get raw data through IO
+    rawData <- getData "output.txt"
+    
+    -- Pure transformations
+    let processed = processLines rawData
+    let icons = extractIcons processed
+    
+    -- Output results
+    mapM_ putStrLn icons
+
+    app <- Gtk.applicationNew (Just "com.example.DictionaryIcons") []
+    
+    void $ Gtk.on app #activate $ do
+        window <- Gtk.applicationWindowNew app
+        Gtk.windowSetTitle window (Just "Dictionary Toolbar")  -- Fixed line
+        Gtk.windowSetDefaultSize window 800 100
+        
+        -- Rest of the code remains the same
+       
+        mainBox <- Gtk.boxNew Gtk.OrientationVertical 0
+        toolbar <- createIconToolbar icons
+        
+        Gtk.boxAppend mainBox toolbar
+        Gtk.windowSetChild window (Just mainBox)
+        Gtk.widgetShow window
+    
+    _ <- applicationRun app Nothing
+    return ()