diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog for `hgg-rasterific` +## 0.2.0.0 — 2026-08-13 + +- Theme font family is now wired through to PNG rendering. +- Follows the hgg-core 0.2 coordinate generalization. +- Bilingual (English / Japanese) haddock. + ## 0.1.0.0 — 2026-07-18 First public release on Hackage. diff --git a/hgg-rasterific.cabal b/hgg-rasterific.cabal --- a/hgg-rasterific.cabal +++ b/hgg-rasterific.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hgg-rasterific -version: 0.1.0.0 +version: 0.2.0.0 extra-doc-files: CHANGELOG.md synopsis: PNG backend for hgg (Rasterific + JuicyPixels) description: @@ -35,8 +35,8 @@ , FontyFruity >= 0.5.3 && < 0.6 , JuicyPixels >= 3.3 && < 3.4 , Rasterific >= 0.7.5 && < 0.8 - , hgg-core ^>= 0.1 - , hgg-frame ^>= 0.1 + , hgg-core ^>= 0.2 + , hgg-frame ^>= 0.2 default-language: Haskell2010 test-suite hgg-rasterific-tests diff --git a/src/Graphics/Hgg/Backend/Rasterific.hs b/src/Graphics/Hgg/Backend/Rasterific.hs --- a/src/Graphics/Hgg/Backend/Rasterific.hs +++ b/src/Graphics/Hgg/Backend/Rasterific.hs @@ -1,23 +1,36 @@ -- | -- Module : Graphics.Hgg.Backend.Rasterific --- Description : raster PNG backend (Phase 22、 Rasterific + FontyFruity) +-- Description : raster PNG backend (Rasterific + FontyFruity) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- plot-core の '[Primitive]' を Rasterific の 'R.Drawing' 命令に解釈して +-- [日本語]: plot-core の '[Primitive]' を Rasterific の 'R.Drawing' 命令に解釈して -- JuicyPixels で PNG エンコードする (SVG/PDF backend と同じ Layer 1 構図)。 --- Rasterific は y 下向き (SVG 同系) なので **y 反転は不要** (PDF と対照的)。 +-- Rasterific は y 下向き (SVG 同系) なので __y 反転は不要__ (PDF と対照的)。 -- --- フォントは FontyFruity の TrueType 読込 = **日本語ラベル対応** +-- [English]: Interprets plot-core's '[Primitive]' as Rasterific 'R.Drawing' +-- instructions and encodes the result to PNG with JuicyPixels (the same +-- Layer 1 structure as the SVG/PDF backends). Since Rasterific has y pointing +-- down (the same convention as SVG), __no y flip is needed__ (unlike PDF). +-- +-- [日本語]: フォントは FontyFruity の TrueType 読込 = __日本語ラベル対応__ -- (PDF v1 制約の受け皿)。 探索は fontconfig 非依存の固定候補リスト -- (明示 'pngFontPath' → 既知ディレクトリ × 既知ファイル名)。 -- ★FontyFruity は .ttc (TrueType Collection) / CFF 系 OTF 非対応 — -- 見つからない時は探索パスを列挙して loud エラー。 +-- +-- [English]: Fonts are loaded via FontyFruity's TrueType reader, which +-- gives __Japanese label support__ (the fallback for PDF's v1 constraint). +-- Font discovery uses a fixed, fontconfig-independent candidate list (an +-- explicit 'pngFontPath' takes priority, otherwise known directories × +-- known file names are searched). Note: FontyFruity does not support .ttc +-- (TrueType Collection) or CFF-flavored OTF — when no font is found, it +-- lists the search paths in a loud error. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Backend.Rasterific ( -- * 通常 (Resolver 不要 = inline 列のみの図) savePNG - -- * Resolver 同伴 (= 'ColByName' を含む図) + -- * Resolver 同伴 (= @ColByName@ を含む図) , savePNGWith -- * Phase 14 系: BoundPlot (df バインド済) を描画する , savePNGBound @@ -30,6 +43,8 @@ -- * フォント解決 (診断 / テスト用) , PNGFonts (..) , loadPNGFonts + , loadPNGFontsFor + , normFamily ) where import Graphics.Hgg.Frame (BoundPlot (..)) @@ -40,15 +55,18 @@ Primitive (..), StrokeStyle (..), TextAnchor (..), TextStyle (..), Transform (..), renderToPrimitives, - scalePrimitives) + scalePrimitives, specThemePalette, + tpShowBackground) import Graphics.Hgg.Spec (Resolver, VisualSpec, emptyResolver, vsDpi) import Data.Monoid (getLast) import Graphics.Hgg.Validate (Severity (..), diagnosticSeverity, - renderDiagnostic) + renderDiagnostic, + reportFacetInlineWarnings, + reportTernaryMarkWarnings) import Codec.Picture (PixelRGBA8 (..), writePng) import Data.Char (digitToInt, isHexDigit, toLower) -import Data.List (intercalate) +import Data.List (intercalate, nub) import Data.Text (Text) import qualified Data.Text as T import qualified Graphics.Rasterific as R @@ -64,14 +82,22 @@ -- 設定 -- =========================================================================== --- | PNG 出力設定。 'defaultPNGConfig' から record update で部分指定する。 +-- | [日本語]: PNG 出力設定。 'defaultPNGConfig' から record update で部分指定する。 +-- [English]: PNG output settings. Specify individual fields via a record +-- update on 'defaultPNGConfig'. data PNGConfig = PNGConfig { pngFontPath :: Maybe FilePath - -- ^ regular TTF の明示指定 (最優先)。 Nothing = 候補リスト探索 + -- ^ [日本語]: regular TTF の明示指定 (最優先)。 Nothing = 候補リスト探索 + -- [English]: An explicit regular TTF path (highest priority). + -- Nothing means searching the candidate list. , pngFontPathBold :: Maybe FilePath - -- ^ bold TTF。 Nothing = bold 候補探索 → 無ければ regular で代替 + -- ^ [日本語]: bold TTF。 Nothing = bold 候補探索 → 無ければ regular で代替 + -- [English]: The bold TTF. Nothing means searching the bold + -- candidates, falling back to regular if none is found. , pngScale :: Double - -- ^ Hi-DPI 倍率 (既定 1.0 = SVG と同 pixel 寸法)。 2.0 で縦横 2 倍 + -- ^ [日本語]: Hi-DPI 倍率 (既定 1.0 = SVG と同 pixel 寸法)。 2.0 で縦横 2 倍 + -- [English]: The Hi-DPI scale factor (default 1.0, giving the same + -- pixel dimensions as SVG). 2.0 doubles both width and height. } deriving (Show, Eq) defaultPNGConfig :: PNGConfig @@ -85,27 +111,39 @@ -- 入口 (PDF backend の savePDF / savePDFWith / savePDFBound と対称) -- =========================================================================== --- | PNG ファイルに保存。 Resolver 不要 (= inline 列のみの図、 = 通常)。 --- 列名参照を含む図は 'savePNGWith'、 DataFrame は 'savePNGBound' (@df |>> spec@)。 +-- | [日本語]: PNG ファイルに保存。 Resolver 不要 (= inline 列のみの図、 = 通常)。 +-- 列名参照を含む図は 'savePNGWith'、 DataFrame は 'savePNGBound' (@df |>> spec@)。 +-- [English]: Saves to a PNG file. No 'Resolver' needed (figures with +-- inline columns only — the usual case). For figures with column-name +-- references use 'savePNGWith'; for a DataFrame use 'savePNGBound' +-- (@df |>> spec@). savePNG :: FilePath -> VisualSpec -> IO () savePNG path = savePNGWith path emptyResolver --- | 'Resolver' を渡して PNG ファイルに保存。 'ColByName' を含む図用。 +-- | [日本語]: 'Resolver' を渡して PNG ファイルに保存。 @ColByName@ を含む図用。 +-- [English]: Saves to a PNG file given a 'Resolver'. For figures that +-- include @ColByName@. savePNGWith :: FilePath -> Resolver -> VisualSpec -> IO () savePNGWith = savePNGConfigured defaultPNGConfig --- | 'BoundPlot' (= @df |>> spec@ の結果) を PNG ファイルに保存。 --- Error severity の検証診断は stderr に報告してから書き出す --- (savePDFBound と同じ lenient 既定)。 +-- | [日本語]: 'BoundPlot' (= @df |>> spec@ の結果) を PNG ファイルに保存。 +-- Error severity の検証診断は stderr に報告してから書き出す +-- (savePDFBound と同じ lenient 既定)。 +-- [English]: Saves a 'BoundPlot' (the result of @df |>> spec@) to a PNG +-- file. Reports error-severity validation diagnostics to stderr before +-- writing the file (the same lenient default as savePDFBound). savePNGBound :: FilePath -> BoundPlot -> IO () savePNGBound path (BoundPlot r spec diags) = do mapM_ (hPutStrLn stderr . T.unpack . renderDiagnostic) (filter ((== SevError) . diagnosticSeverity) diags) savePNGWith path r spec --- | 'PNGConfig' 付き保存 (フォント明示 / Hi-DPI)。 +-- | [日本語]: 'PNGConfig' 付き保存 (フォント明示 / Hi-DPI)。 +-- [English]: Saves with a 'PNGConfig' (explicit font / Hi-DPI). savePNGConfigured :: PNGConfig -> FilePath -> Resolver -> VisualSpec -> IO () savePNGConfigured cfg path r spec = do + reportFacetInlineWarnings r spec -- ★ Phase 62 A4 (§3): 描画は継続 + reportTernaryMarkWarnings r spec -- Phase 64 A13: coordTernary unsupported mark -- ★ Phase 33 B5: layout/prims は純 pt。PNG は raster なので k=dpi/72 を一度だけ -- 掛けて device px へ (HS SVG backend と同一・唯一の dpi 適用点)。font size も -- scalePrimitives で device px になり、drawTextPrim の px→point 変換はそのまま整合。 @@ -116,21 +154,42 @@ ViewportSize wpt hpt = lpViewport layout w = round (fromIntegral wpt * k) :: Int h = round (fromIntegral hpt * k) :: Int - savePrimitivesPNG cfg path w h prims + -- ★ Phase 63 A18: 背景を塗らない theme (themePlotBg False) は init を透過に + -- (背景 rect が無いので init 色がそのまま残るため)。 塗る theme は従来どおり + -- 白 init (= 既存図の bit 単位不変を保証。 透過 init だと全面 rect の縁 AA で + -- 端 pixel の alpha が変わり得る)。 + bgPx = if tpShowBackground (specThemePalette spec) + then PixelRGBA8 255 255 255 255 + else PixelRGBA8 0 0 0 0 + savePrimitivesPNGBg bgPx cfg path w h prims --- | Phase 24 A8: [Primitive] 列を所与のキャンバスサイズで PNG に直接描画する --- 低レベル経路 ('savePrimitivesSVG' の PNG 版)。 2D の 'savePNGConfigured' と --- 3D の 'savePNG3D' が共有。 'pngScale' で Hi-DPI 拡大。 +-- | [日本語]: [Primitive] 列を所与のキャンバスサイズで PNG に直接描画する +-- 低レベル経路 (@savePrimitivesSVG@ の PNG 版)。 2D の 'savePNGConfigured' と +-- 3D の @savePNG3D@ が共有。 'pngScale' で Hi-DPI 拡大。 +-- [English]: A low-level path that draws a list of Primitives directly to +-- PNG at a given canvas size (the PNG counterpart of @savePrimitivesSVG@). +-- Shared by 2D's 'savePNGConfigured' and 3D's @savePNG3D@. Hi-DPI scaling +-- is applied via 'pngScale'. savePrimitivesPNG :: PNGConfig -> FilePath -> Int -> Int -> [Primitive] -> IO () -savePrimitivesPNG cfg path w h prims = do +savePrimitivesPNG = savePrimitivesPNGBg (PixelRGBA8 255 255 255 255) + +-- | [日本語]: init 色指定版 (内部)。 通常は init 白 + [Primitive] 先頭の背景 rect が全面を +-- 塗る (Render/Layer.hs の background) ので実質 theme 色になる。 +-- 背景を塗らない theme では 'savePNGConfigured' が透過 init を渡す。 +-- [English]: The internal variant that takes an explicit init color. +-- Normally the init is white, and the background rect at the head of +-- [Primitive] fills the whole canvas (Render/Layer.hs's background), so +-- the effective color is the theme's. For a theme that does not paint a +-- background, 'savePNGConfigured' passes a transparent init instead. +savePrimitivesPNGBg :: PixelRGBA8 -> PNGConfig -> FilePath -> Int -> Int + -> [Primitive] -> IO () +savePrimitivesPNGBg bg cfg path w h prims = do let s = max 1e-3 (pngScale cfg) wI = max 1 (ceiling (fromIntegral w * s)) :: Int hI = max 1 (ceiling (fromIntegral h * s)) :: Int - fonts <- loadPNGFonts cfg - -- 画像初期化は白。 theme 背景は [Primitive] 先頭の背景 rect が全面を塗る - -- (Render/Layer.hs の background) ので実質 theme 色になる。 - let bg = PixelRGBA8 255 255 255 255 - img = R.renderDrawing wI hI bg $ + -- ★ Phase 63 A20.5: 使用 family を先に収集して束を解決 (fontFamily の PNG 配線) + fonts <- loadPNGFontsFor cfg [ tsFamily ts | PText _ _ ts <- prims ] + let img = R.renderDrawing wI hI bg $ R.withTransformation (RTr.scale (f s) (f s)) $ drawPrims fonts prims writePng path img @@ -139,14 +198,28 @@ -- フォント探索 (fontconfig 非依存・決定的) -- =========================================================================== --- | 解釈器に渡すフォント束。 v1 は family 非区別 (regular/bold の 2 face のみ。 --- 日本語 .ttf で serif/italic が揃う環境は稀のため。 計画 md の設計判断)。 +-- | [日本語]: 解釈器に渡すフォント束。 既定 (sans-serif) は regular/bold の 2 face、 +-- spec の @fontFamily@ 指定分は 'pfFamilies' +-- (正規化 family 名 → face 対) で解決する。 italic は引き続き regular 代替 +-- (日本語 .ttf で italic が揃う環境は稀のため。 計画 md の設計判断)。 +-- [English]: The font bundle passed to the interpreter. The default +-- (sans-serif) has 2 faces, regular/bold; a spec's @fontFamily@ is +-- resolved via 'pfFamilies' (normalized family name to face pair). +-- Italic still falls back to regular (a design decision, since +-- environments with an italic Japanese .ttf available are rare). data PNGFonts = PNGFonts - { pfRegular :: F.Font - , pfBold :: F.Font + { pfRegular :: F.Font + , pfBold :: F.Font + , pfFamilies :: [(String, (F.Font, F.Font))] + -- ^ [日本語]: 'normFamily' 済 family 名 → (regular, bold)。 未収載 family は既定束へ fallback + -- [English]: A map from normalized family name (via 'normFamily') to + -- (regular, bold). A family not listed falls back to the default + -- bundle. } --- | 候補ディレクトリ (存在するものだけ走査・/usr/share/fonts は再帰)。 +-- | [日本語]: 候補ディレクトリ (存在するものだけ走査・/usr/share/fonts は再帰)。 +-- [English]: The candidate directories (only existing ones are scanned; +-- /usr/share/fonts is scanned recursively). fontSearchDirs :: IO [FilePath] fontSearchDirs = do home <- getHomeDirectory @@ -158,9 +231,14 @@ , "/mnt/c/Windows/Fonts" -- WSL (※日本語は .ttc が多く対象外になりがち) ] --- | 候補ファイル名 (優先順・小文字比較)。 日本語対応 .ttf を先頭に、 --- 最後に Latin のみの DejaVu (JP フォント不在環境の文字化け回避より --- 「とりあえず描ける」 を優先。 JP が必要なら pngFontPath で明示)。 +-- | [日本語]: 候補ファイル名 (優先順・小文字比較)。 日本語対応 .ttf を先頭に、 +-- 最後に Latin のみの DejaVu (JP フォント不在環境の文字化け回避より +-- 「とりあえず描ける」 を優先。 JP が必要なら pngFontPath で明示)。 +-- [English]: The candidate file names, in priority order (matched +-- case-insensitively). Japanese-capable .ttf fonts come first, with the +-- Latin-only DejaVu last (prioritizing "something renders" over avoiding +-- mojibake in an environment without a Japanese font. Set pngFontPath +-- explicitly if Japanese support is required). regularCandidates :: [String] regularCandidates = [ "hackgen-regular.ttf" @@ -181,9 +259,54 @@ , "dejavusans-bold.ttf" ] --- | フォント load。 明示 path → 候補探索 → loud エラー。 +-- | [日本語]: generic family "serif" / "monospace" の候補 (regular, bold の対)。 +-- [English]: Candidates for the generic families "serif" / "monospace" +-- (regular, bold pairs). +serifCandidates, serifBoldCandidates, monoCandidates, monoBoldCandidates :: [String] +serifCandidates = + [ "notoserifcjkjp-regular.ttf", "notoserifjp-regular.ttf" + , "ipamp.ttf", "ipam.ttf", "takaopmincho.ttf", "takaomincho.ttf" + , "dejavuserif.ttf" + ] +serifBoldCandidates = + [ "notoserifcjkjp-bold.ttf", "notoserifjp-bold.ttf", "dejavuserif-bold.ttf" ] +monoCandidates = + [ "hackgen-regular.ttf", "dejavusansmono.ttf", "hack-regular.ttf" ] +monoBoldCandidates = + [ "hackgen-bold.ttf", "dejavusansmono-bold.ttf", "hack-bold.ttf" ] + +-- | [日本語]: family 名の正規化 (小文字化 + 空白/ハイフン除去)。 索引はファイル名の小文字 +-- 完全一致なので "DejaVu Sans" → "dejavusans" → dejavusans.ttf のように引ける。 +-- [English]: Normalizes a family name (lowercases and strips spaces and +-- hyphens). Since the index is keyed by lowercased file name for exact +-- match, "DejaVu Sans" normalizes to "dejavusans", which then resolves to +-- dejavusans.ttf. +normFamily :: Text -> String +normFamily = filter (\c -> c /= ' ' && c /= '-') . map toLower . T.unpack + +-- | [日本語]: フォント load (family 追加解決なし = 従来互換)。 +-- [English]: Loads fonts without resolving additional families +-- (backward-compatible behavior). loadPNGFonts :: PNGConfig -> IO PNGFonts -loadPNGFonts cfg = do +loadPNGFonts cfg = loadPNGFontsFor cfg [] + +-- | [日本語]: 既定束 + 使用 family 束を load。 +-- 'pngFontPath' 明示時は従来どおり__全 text 一括で最優先__ (family 解決は行わない)。 +-- 解決規則 (fontconfig 非依存を維持): +-- sans-serif/"" → 既定束 / serif・monospace → 専用候補リスト / +-- その他 → 正規化名で @<名>.ttf@ → @<名>-regular.ttf@ (+ @-bold@)。 +-- 見つからない family は stderr 警告 + 既定束 fallback (loud エラーにはしない)。 +-- [English]: Loads the default bundle plus the bundles for the families +-- actually used. When 'pngFontPath' is set explicitly, it still +-- __applies to all text at highest priority__ as before (no family +-- resolution is performed). Resolution rules (staying fontconfig-free): +-- sans-serif/"" resolves to the default bundle; serif/monospace resolve +-- via their dedicated candidate lists; anything else resolves via the +-- normalized name as @.ttf@ then @-regular.ttf@ (plus +-- @-bold@). A family that cannot be found gets a stderr warning and falls +-- back to the default bundle (not a loud error). +loadPNGFontsFor :: PNGConfig -> [Text] -> IO PNGFonts +loadPNGFontsFor cfg families = do index <- ttfIndex reg <- resolveFont index "regular" (pngFontPath cfg) regularCandidates bold <- case pngFontPathBold cfg of @@ -191,8 +314,33 @@ Nothing -> case lookupCandidates index boldCandidates of Just p -> loadOrDie p Nothing -> pure reg -- bold 不在は regular で代替 (v1 制約) - pure (PNGFonts reg bold) + fams <- if pngFontPath cfg /= Nothing + then pure [] -- 明示 path = 全 text 一括 (従来どおり) + else fmap concat . mapM (resolveFamily index) + . nub . filter (`notElem` ["", "sansserif"]) + . map normFamily $ families + pure (PNGFonts reg bold fams) where + -- 未解決 family の fallback は drawTextPrim 側 (map 未収載 = 既定束) + resolveFamily index fam = do + let (regCands, boldCands) = case fam of + "serif" -> (serifCandidates, serifBoldCandidates) + "monospace" -> (monoCandidates, monoBoldCandidates) + "mono" -> (monoCandidates, monoBoldCandidates) + n -> ([n ++ ".ttf", n ++ "-regular.ttf"], [n ++ "-bold.ttf"]) + case lookupCandidates index regCands of + Nothing -> do + hPutStrLn stderr ("hgg-rasterific: fontFamily \"" ++ fam + ++ "\" が見つかりません (候補: " + ++ intercalate ", " regCands + ++ ")。 既定フォントで代替します。") + pure [] + Just p -> do + r <- loadOrDie p + b <- case lookupCandidates index boldCands of + Just pb -> loadOrDie pb + Nothing -> pure r -- family の bold 不在は同 family regular 代替 + pure [(fam, (r, b))] resolveFont index roleName mExplicit candidates = case mExplicit of Just p -> do ok <- doesFileExist p @@ -217,8 +365,11 @@ ++ " (※.ttc/OTF は非対応・.ttf のみ)") die msg = errorWithoutStackTrace ("hgg-rasterific: " ++ msg) --- | 探索ディレクトリ配下の .ttf を再帰列挙して (小文字ファイル名, path) の --- 索引にする。 候補リスト順 (= 優先順) に索引を引く。 +-- | [日本語]: 探索ディレクトリ配下の .ttf を再帰列挙して (小文字ファイル名, path) の +-- 索引にする。 候補リスト順 (= 優先順) に索引を引く。 +-- [English]: Recursively enumerates .ttf files under the search +-- directories into a (lowercased file name, path) index. The index is +-- looked up in candidate-list order (priority order). ttfIndex :: IO [(String, FilePath)] ttfIndex = do dirs <- fontSearchDirs @@ -249,18 +400,25 @@ -- Primitive 解釈器 -- =========================================================================== --- | Double → Float (Rasterific の座標は Float)。 +-- | [日本語]: Double → Float (Rasterific の座標は Float)。 +-- [English]: Double to Float (Rasterific coordinates are Float). f :: Double -> Float f = realToFrac v2 :: Point -> R.Point v2 (Point x y) = R.V2 (f x) (f y) --- | Primitive 列を順に描く。 PClipPush/PTransformPush は対応する Pop までを --- **再帰グルーピング**して 'R.withClipping' / 'R.withTransformation' に入れる --- (PDF backend の drawPrims と同型。 Rasterific の clip/transform も --- scoped combinator なので同じ構図が自然に合う)。 --- 対応の取れない Pop は黙って無視 (SVG backend と同じ寛容さ)。 +-- | [日本語]: Primitive 列を順に描く。 PClipPush/PTransformPush は対応する Pop までを +-- __再帰グルーピング__して 'R.withClipping' / 'R.withTransformation' に入れる +-- (PDF backend の drawPrims と同型。 Rasterific の clip/transform も +-- scoped combinator なので同じ構図が自然に合う)。 +-- 対応の取れない Pop は黙って無視 (SVG backend と同じ寛容さ)。 +-- [English]: Draws the list of Primitives in order. PClipPush/PTransformPush +-- __recursively groups__ everything up to the matching Pop and wraps it in +-- 'R.withClipping' / 'R.withTransformation' (the same shape as the PDF +-- backend's drawPrims — Rasterific's clip/transform are also scoped +-- combinators, so the same structure fits naturally). An unmatched Pop is +-- silently ignored (the same leniency as the SVG backend). drawPrims :: PNGFonts -> [Primitive] -> R.Drawing PixelRGBA8 () drawPrims fonts = go where @@ -269,6 +427,13 @@ let (inner, after) = breakMatch isClipPush isClipPop rest in do R.withClipping (R.fill (rectShape rect)) (go inner) go after + -- Phase 64 §2: 多角形 clip。 3 点未満は clip 無しで内側をそのまま描く (素通し)。 + go (PClipPath pts : rest) = + let (inner, after) = breakMatch isClipPush isClipPop rest + in do if length pts < 3 + then go inner + else R.withClipping (R.fill (polyShape pts)) (go inner) + go after go (PTransformPush tr : rest) = let (inner, after) = breakMatch isTrPush isTrPop rest in do R.withTransformation (transformOf tr) (go inner) @@ -277,13 +442,18 @@ go (PTransformPop : rest) = go rest go (p : rest) = drawOne fonts p >> go rest - isClipPush p = case p of { PClipPush _ -> True; _ -> False } + -- clip push は矩形版 / 多角形版の 2 種。 入れ子の数え上げでは同じ「push」 扱い。 + isClipPush p = case p of { PClipPush _ -> True; PClipPath _ -> True; _ -> False } isClipPop p = case p of { PClipPop -> True; _ -> False } isTrPush p = case p of { PTransformPush _ -> True; _ -> False } isTrPop p = case p of { PTransformPop -> True; _ -> False } --- | 同種 push の入れ子を数えながら、 対応する pop までの内側と残りに割る。 --- 対応 pop が無ければ全部内側 (= 末尾まで clip が効く・SVG の開きっ放しと同義)。 +-- | [日本語]: 同種 push の入れ子を数えながら、 対応する pop までの内側と残りに割る。 +-- 対応 pop が無ければ全部内側 (= 末尾まで clip が効く・SVG の開きっ放しと同義)。 +-- [English]: Counts nested pushes of the same kind and splits the list +-- into the inner part (up to the matching pop) and the rest. If there is +-- no matching pop, everything is treated as inner (the clip stays in +-- effect to the end — the same as SVG leaving it open). breakMatch :: (Primitive -> Bool) -> (Primitive -> Bool) -> [Primitive] -> ([Primitive], [Primitive]) breakMatch isPush isPop = walk (0 :: Int) @@ -296,12 +466,17 @@ (inner, after) = walk n' rest in (p : inner, after) --- | SVG 系 Transform → Rasterific Transformation (y 下向き同士なのでそのまま)。 +-- | [日本語]: SVG 系 Transform → Rasterific Transformation (y 下向き同士なのでそのまま)。 +-- [English]: Converts an SVG-style Transform to a Rasterific +-- Transformation (passed through unchanged, since both have y pointing +-- down). transformOf :: Transform -> RTr.Transformation transformOf (TranslateT dx dy) = RTr.translate (R.V2 (f dx) (f dy)) transformOf (ScaleT sx sy) = RTr.scale (f sx) (f sy) --- | 単独 primitive の描画。 push/pop は 'drawPrims' が先に消費する。 +-- | [日本語]: 単独 primitive の描画。 push/pop は 'drawPrims' が先に消費する。 +-- [English]: Draws a single primitive. push/pop are consumed beforehand by +-- 'drawPrims'. drawOne :: PNGFonts -> Primitive -> R.Drawing PixelRGBA8 () drawOne _ (PLine a b ls) = drawLine a b ls drawOne _ (PRect rect fs ms) = drawRect rect fs ms @@ -310,13 +485,17 @@ drawOne fonts (PText p s ts) = drawTextPrim fonts p s ts drawOne _ _ = pure () --- | 線分: 色/幅/破線。 cap は SVG 既定 butt 相当 (CapStraight 0)。 +-- | [日本語]: 線分: 色/幅/破線。 cap は SVG 既定 butt 相当 (CapStraight 0)。 +-- [English]: Line segment: color, width and dash pattern. The cap +-- corresponds to SVG's default butt cap (CapStraight 0). drawLine :: Point -> Point -> LineStyle -> R.Drawing PixelRGBA8 () drawLine a b (LineStyle col w dash) = R.withTexture (RT.uniformTexture (colorOf col 1.0)) $ strokeMaybeDashed dash (f w) (R.line (v2 a) (v2 b)) --- | dash 配列 (px) が空なら実線、 あれば dashedStroke。 +-- | [日本語]: dash 配列 (px) が空なら実線、 あれば dashedStroke。 +-- [English]: A solid stroke if the dash array (px) is empty, otherwise a +-- dashedStroke. strokeMaybeDashed :: [Double] -> Float -> [R.Primitive] -> R.Drawing PixelRGBA8 () strokeMaybeDashed dash w geom = case dash of @@ -329,17 +508,34 @@ rectShape :: Rect -> [R.Primitive] rectShape (Rect x y w h) = R.rectangle (R.V2 (f x) (f y)) (f w) (f h) --- | 矩形: fill (+ 任意 stroke)。 'Rect' は左上基準 = Rasterific と同じ。 +-- | [日本語]: 多角形 shape ('PClipPath' 用)。 頂点列を辺で繋ぎ、 **最後→最初も +-- 繋いで閉じる** ('PClipPath' の暗黙 close 規約)。 +-- [English]: Polygon shape (for 'PClipPath'). Connects the vertices with +-- edges and **closes the loop from last back to first** (the implicit +-- close contract of 'PClipPath'). +polyShape :: [Point] -> [R.Primitive] +polyShape [] = [] +polyShape pts = concat (zipWith seg pts (drop 1 pts ++ [head pts])) + where + seg a b = R.line (v2 a) (v2 b) + +-- | [日本語]: 矩形: fill (+ 任意 stroke)。 'Rect' は左上基準 = Rasterific と同じ。 +-- [English]: Rectangle: fill (+ optional stroke). 'Rect' is anchored at +-- the top-left, matching Rasterific's convention. drawRect :: Rect -> FillStyle -> Maybe StrokeStyle -> R.Drawing PixelRGBA8 () drawRect rect fs ms = fillShape (rectShape rect) fs ms --- | 円: fill (+ 任意 stroke)。 hover label は PNG では捨てる (PDF と同じ)。 +-- | [日本語]: 円: fill (+ 任意 stroke)。 hover label は PNG では捨てる (PDF と同じ)。 +-- [English]: Circle: fill (+ optional stroke). The hover label is dropped +-- in PNG output (as with PDF). drawCircle :: Point -> Double -> FillStyle -> Maybe StrokeStyle -> R.Drawing PixelRGBA8 () drawCircle c rad fs ms = fillShape (R.circle (v2 c) (f rad)) fs ms --- | Shape 共通: FillStyle (色 + opacity → alpha 合成) で塗り、 --- StrokeStyle があれば縁取る。 +-- | [日本語]: Shape 共通: FillStyle (色 + opacity → alpha 合成) で塗り、 +-- StrokeStyle があれば縁取る。 +-- [English]: Common to all shapes: paints with FillStyle (color + opacity +-- composited to alpha), and outlines with StrokeStyle if present. fillShape :: [R.Primitive] -> FillStyle -> Maybe StrokeStyle -> R.Drawing PixelRGBA8 () fillShape shape (FillStyle col opa) ms = do @@ -352,10 +548,15 @@ R.withTexture (RT.uniformTexture (colorOf sc 1.0)) $ strokeMaybeDashed [] (f sw) shape --- | パス: MoveTo 区切りで subpath ('R.Path') に分割して fill / stroke。 --- fill は全 subpath の primitive をまとめて 1 回 (= SVG の nonzero winding が --- subpath 横断で効く)、 stroke は subpath ごと (= まとめると subpath 間に --- 偽の接続 join が入る) に塗り分ける。 +-- | [日本語]: パス: MoveTo 区切りで subpath ('R.Path') に分割して fill / stroke。 +-- fill は全 subpath の primitive をまとめて 1 回 (= SVG の nonzero winding が +-- subpath 横断で効く)、 stroke は subpath ごと (= まとめると subpath 間に +-- 偽の接続 join が入る) に塗り分ける。 +-- [English]: Path: splits into subpaths ('R.Path') at MoveTo boundaries +-- for fill / stroke. Fill combines the primitives of all subpaths into a +-- single call (so SVG's nonzero winding rule applies across subpaths), +-- while stroke is done per subpath (combining them would introduce a +-- spurious join between subpaths). drawPath :: [PathSegment] -> FillStyle -> Maybe StrokeStyle -> R.Drawing PixelRGBA8 () drawPath [] _ _ = pure () @@ -371,9 +572,14 @@ R.withTexture (RT.uniformTexture (colorOf sc 1.0)) $ mapM_ (strokeMaybeDashed [] (f sw)) subPrims --- | 'PathSegment' 列 → 'R.Path' 列。 MoveTo で新 subpath、 ClosePath は --- 現 subpath の close フラグ (以降に命令が続く稀ケースは同じ原点で新 subpath)。 --- 先頭が MoveTo でない場合は原点 (0,0) 開始 (PDF backend と同じ寛容さ)。 +-- | [日本語]: 'PathSegment' 列 → 'R.Path' 列。 MoveTo で新 subpath、 ClosePath は +-- 現 subpath の close フラグ (以降に命令が続く稀ケースは同じ原点で新 subpath)。 +-- 先頭が MoveTo でない場合は原点 (0,0) 開始 (PDF backend と同じ寛容さ)。 +-- [English]: Converts a list of 'PathSegment' to a list of 'R.Path'. +-- MoveTo starts a new subpath; ClosePath sets the close flag on the +-- current subpath (in the rare case more commands follow, a new subpath +-- starts at the same origin). If the list does not start with MoveTo, it +-- starts at the origin (0,0) — the same leniency as the PDF backend. splitSubpaths :: [PathSegment] -> [R.Path] splitSubpaths = go (R.V2 0 0) [] where @@ -391,13 +597,24 @@ closeOff origin acc closed rest = R.Path origin closed (reverse acc) : rest --- | テキスト: 'R.printTextAt' (基準点 = baseline 開始 = SVG の text y と同義)。 --- anchor は 'F.stringBoundingBox' の advance width (_xMax 位置に格納・ --- FontyFruity ソース実測) で x 補正。 tsRotate (degrees CW・SVG 同義) は --- y 下向き同士なので符号そのまま (PDF と対照的)、 rotate→translate の合成で --- (x,y) 周りに回す。 tsSize は px → 'F.pixelSizeInPointAtDpi' で 96 dpi の --- point に変換 ('R.renderDrawing' = 96 dpi 固定)。 --- v1 は family 非区別: tsWeight == "bold" のみ分岐、 italic は regular で代替。 +-- | [日本語]: テキスト: 'R.printTextAt' (基準点 = baseline 開始 = SVG の text y と同義)。 +-- anchor は 'F.stringBoundingBox' の advance width (_xMax 位置に格納・ +-- FontyFruity ソース実測) で x 補正。 tsRotate (degrees CW・SVG 同義) は +-- y 下向き同士なので符号そのまま (PDF と対照的)、 rotate→translate の合成で +-- (x,y) 周りに回す。 tsSize は px → 'F.pixelSizeInPointAtDpi' で 96 dpi の +-- point に変換 ('R.renderDrawing' = 96 dpi 固定)。 +-- tsFamily を 'pfFamilies' (正規化名) で解決、 未収載は +-- 既定束へ fallback。 italic は引き続き regular で代替。 +-- [English]: Text: uses 'R.printTextAt' (whose reference point — the +-- baseline start — matches SVG's text y). The anchor is x-corrected using +-- the advance width from 'F.stringBoundingBox' (stored at _xMax, as +-- verified against the FontyFruity source). tsRotate (degrees CW, matching +-- SVG) keeps its sign as-is since both use y pointing down (unlike PDF), +-- and is applied by composing rotate then translate around (x,y). tsSize +-- is converted from px to a 96 dpi point via 'F.pixelSizeInPointAtDpi' +-- ('R.renderDrawing' is fixed at 96 dpi). tsFamily is resolved via +-- 'pfFamilies' (normalized name); a family not listed falls back to the +-- default bundle. Italic still falls back to regular. drawTextPrim :: PNGFonts -> Point -> Text -> TextStyle -> R.Drawing PixelRGBA8 () drawTextPrim fonts (Point x y) txt ts = @@ -411,7 +628,10 @@ <> RTr.rotate (f (negate (tsRotate ts)) * pi / 180)) (R.printTextAt font sizePt (R.V2 dx 0) str) where - font = if tsWeight ts == "bold" then pfBold fonts else pfRegular fonts + isBold = tsWeight ts == "bold" + font = case lookup (normFamily (tsFamily ts)) (pfFamilies fonts) of + Just (r, b) -> if isBold then b else r + Nothing -> if isBold then pfBold fonts else pfRegular fonts sizePt = F.pixelSizeInPointAtDpi (f (max 1 (tsSize ts))) 96 str = T.unpack txt advW = F._xMax (F.stringBoundingBox font 96 sizePt str) @@ -424,8 +644,11 @@ -- 色 (theme 色は全て "#rrggbb" hex。 named / 不正は黒 fallback) -- =========================================================================== --- | hex 色 + opacity → PixelRGBA8 (opacity は alpha 成分に畳む = --- PDF v1 の opacity 問題は PNG では起きない)。 +-- | [日本語]: hex 色 + opacity → PixelRGBA8 (opacity は alpha 成分に畳む = +-- PDF v1 の opacity 問題は PNG では起きない)。 +-- [English]: Converts a hex color + opacity to PixelRGBA8 (opacity is +-- folded into the alpha channel — the opacity limitation of PDF v1 does +-- not occur in PNG). colorOf :: Text -> Double -> PixelRGBA8 colorOf t opa = case T.unpack t of ['#', r1, r2, g1, g2, b1, b2] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,13 +6,21 @@ import Graphics.Hgg.Backend.Rasterific (PNGConfig (..), PNGFonts (..), defaultPNGConfig, loadPNGFonts, - savePNG, savePNGConfigured) + loadPNGFontsFor, normFamily, + savePNG, savePNGConfigured, + savePrimitivesPNG) import Graphics.Hgg.Easy -import Codec.Picture (Image (..), PixelRGBA8, - convertRGBA8, decodePng) +import Graphics.Hgg.Layout (Rect (..), computeLayout) +import Graphics.Hgg.Render (FillStyle (..), Point (..), + Primitive (..), + renderToPrimitives) +import Codec.Picture (Image (..), PixelRGBA8 (..), + convertRGBA8, decodePng, + pixelAt) import qualified Data.ByteString as BS import qualified Graphics.Text.TrueType as F -import System.Directory (getTemporaryDirectory, +import System.Directory (doesFileExist, + getTemporaryDirectory, removeFile) import System.FilePath (()) import Test.Hspec @@ -63,10 +71,16 @@ <> coordCartesianX 1.5 3.5 w `shouldSatisfy` (> 100) - it "facet (複数 panel) が例外なく書ける" $ do - (w, _) <- saveAndDecode "hgg-png-test-facet.png" $ - layer (scatter (inline [1, 2, 3, 4]) (inline [2, 4, 1, 3])) - <> facet (inlineCat (["g1", "g1", "g2", "g2"] :: [String])) + -- Phase 62: 旧テストは「例外なく書ける」 + 幅だけの検証で、 inline facet が + -- 未分割 (全 panel に同一データ) でも通ってしまっていた。 PCircle 数で + -- 分割成立 (4 点。 未分割バグ時は 8) を固定した上で PNG 書き出しも確認する。 + it "facet (複数 panel) が inline encoding を分割して書ける (PCircle=4)" $ do + let spec = layer (scatter (inline [1, 2, 3, 4]) (inline [2, 4, 1, 3])) + <> facet (inlineCat (["g1", "g1", "g2", "g2"] :: [String])) + prims = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + length [() | PCircle{} <- prims] `shouldBe` 4 + (w, _) <- saveAndDecode "hgg-png-test-facet.png" spec w `shouldSatisfy` (> 100) it "coordPolar が例外なく書ける" $ do @@ -75,6 +89,38 @@ <> coordPolar w `shouldSatisfy` (> 100) + describe "Phase 64 A7: PClipPath (多角形 clip)" $ do + -- 200x200 の全面赤 rect を三角形 (100,20)-(180,180)-(20,180) で clip し、 + -- 三角形の内外を pixel で直接確かめる (= clip が実際に効いている証拠)。 + let triClip pts = + [ PClipPath pts + , PRect (Rect 0 0 200 200) (FillStyle "#ff0000" 1) Nothing + , PClipPop ] + tri = [Point 100 20, Point 180 180, Point 20 180] + renderPrims name prims = do + tmp <- getTemporaryDirectory + let path = tmp name + savePrimitivesPNG defaultPNGConfig path 200 200 prims + bs <- BS.readFile path + removeFile path + case decodePng bs of + Left err -> error ("PNG decode 失敗: " ++ err) + Right dyn -> pure (convertRGBA8 dyn) + isRed (PixelRGBA8 r g b _) = r > 200 && g < 60 && b < 60 + + it "三角形の内側だけが塗られる (外側の角は背景のまま)" $ do + img <- renderPrims "hgg-png-test-clippath.png" (triClip tri) + isRed (pixelAt img 100 150) `shouldBe` True -- 三角形の内側 + isRed (pixelAt img 5 5) `shouldBe` False -- 左上の角 (外側) + isRed (pixelAt img 195 5) `shouldBe` False -- 右上の角 (外側) + isRed (pixelAt img 100 5) `shouldBe` False -- 頂点より上 (外側) + + it "頂点 3 点未満は clip 無し = 全面が塗られる (素通し)" $ do + img <- renderPrims "hgg-png-test-clippath-degenerate.png" + (triClip [Point 10 10, Point 20 20]) + isRed (pixelAt img 100 150) `shouldBe` True + isRed (pixelAt img 5 5) `shouldBe` True + describe "Phase 22 A3: PText (TrueType・anchor/rotate・日本語)" $ do it "title + 軸ラベル (回転 y ラベル含む) が例外なく書ける" $ do (w, _) <- saveAndDecode "hgg-png-test-text.png" $ @@ -112,3 +158,28 @@ img2 <- save 2.0 "hgg-png-test-2x.png" imageWidth img2 `shouldBe` 2 * imageWidth img1 imageHeight img2 `shouldBe` 2 * imageHeight img1 + + describe "Phase 63 A20.5: fontFamily の PNG 配線" $ do + it "normFamily: 小文字化 + 空白/ハイフン除去" $ do + normFamily "DejaVu Sans" `shouldBe` "dejavusans" + normFamily "sans-serif" `shouldBe` "sansserif" + normFamily "HackGen" `shouldBe` "hackgen" + it "未解決 family は警告 + 既定束 fallback (pfFamilies 非収載)" $ do + fonts <- loadPNGFontsFor defaultPNGConfig ["NoSuchFontFamily12345"] + map fst (pfFamilies fonts) `shouldBe` [] + it "pngFontPath 明示時は family 解決を行わない (全 text 一括最優先)" $ do + let p = "/usr/share/fonts/TTF/DejaVuSans.ttf" + ok <- doesFileExist p + if not ok + then pendingWith "DejaVuSans.ttf が無い環境のため skip" + else do + fonts <- loadPNGFontsFor defaultPNGConfig { pngFontPath = Just p } + ["HackGen"] + map fst (pfFamilies fonts) `shouldBe` [] + it "存在する family は収載され glyph が引ける" $ do + ok <- doesFileExist "/usr/share/fonts/TTF/DejaVuSans.ttf" + if not ok + then pendingWith "DejaVuSans.ttf が無い環境のため skip" + else do + fonts <- loadPNGFontsFor defaultPNGConfig ["DejaVu Sans"] + map fst (pfFamilies fonts) `shouldBe` ["dejavusans"]