From ab87c7c384bd183b1af266413b47ad97f7b46a45 Mon Sep 17 00:00:00 2001 From: Mihail Ivanchev Date: Wed, 9 Apr 2025 12:29:58 +0200 Subject: [PATCH 1/2] SDL2 TTF font renderering, fist try. --- README.org | 1 + util/sdl-fonts/README.md | 34 +++++ util/sdl-fonts/package.lisp | 24 +++ util/sdl-fonts/sdl-fonts.asd | 12 ++ util/sdl-fonts/sdl-fonts.lisp | 270 ++++++++++++++++++++++++++++++++++ 5 files changed, 341 insertions(+) create mode 100644 util/sdl-fonts/README.md create mode 100644 util/sdl-fonts/package.lisp create mode 100644 util/sdl-fonts/sdl-fonts.asd create mode 100644 util/sdl-fonts/sdl-fonts.lisp diff --git a/README.org b/README.org index 0b66f4a..d06ca1d 100644 --- a/README.org +++ b/README.org @@ -129,6 +129,7 @@ Advertise your module here, open a PR and include a org-mode link! - [[./util/productivity/README.org][productivity]] :: Lock StumpWM down so you have to get work done. - [[./util/qubes/README.org][qubes]] :: Integration to Qubes OS (https://www.qubes-os.org) - [[./util/screenshot/README.org][screenshot]] :: Takes screenshots and stores them as png files +- [[./util/sdl-fonts/README.md][sdl-fonts]] :: SDL-based TTF font rendering for StumpWM. - [[./util/searchengines/README.org][searchengines]] :: Allows searching text using prompt or clipboard contents with various search engines - [[./util/shell-command-history/README.org][shell-command-history]] :: Save and load the stumpwm::*input-shell-history* to a file - [[./util/spatial-groups/README][spatial-groups]] :: Spatial Groups navigation for StumpWM diff --git a/util/sdl-fonts/README.md b/util/sdl-fonts/README.md new file mode 100644 index 0000000..bf12636 --- /dev/null +++ b/util/sdl-fonts/README.md @@ -0,0 +1,34 @@ +A TTF renderer for StumpWM which uses SDL. SDL is actively developed by the +whole world so the TTF code is hopefully good as well. + +This module requires the native packages SDL2, SDL2_ttf and libffi. +Make sure they are installed. + +Load a font through by + +``` +(defparameter *the-font* (sdl-fonts:load-font "/usr/share/fonts/TTF/DroidSansMono.ttf" 14)) +``` + +And use it through + +``` +(set-font *the-font*) +``` + +Of course you can also use multiple fonts. Additionally, you can specify +the hinting and kerning by passing + +``` +:hinting <:normal|:light|:mono|:none|:light-subpixel> +:kerning +``` + +to `sdl-fonts:load-font`. + +Have fun! + +Use at your own risk and discretion. I assume no responsibility for any damage +resulting from using this project. I do use it myself. + +This modules borrows ideas and code from clx-truetype. diff --git a/util/sdl-fonts/package.lisp b/util/sdl-fonts/package.lisp new file mode 100644 index 0000000..100d28b --- /dev/null +++ b/util/sdl-fonts/package.lisp @@ -0,0 +1,24 @@ +;;;; package.lisp + +(defpackage #:sdl-fonts + (:use #:cl)) + +(in-package #:sdl-fonts) + +(import '(stumpwm::font-exists-p + stumpwm::open-font + stumpwm::close-font + stumpwm::font-ascent + stumpwm::font-descent + stumpwm::text-line-width + stumpwm::draw-image-glyphs + stumpwm::font-height + cffi:define-foreign-library + cffi:use-foreign-library + cffi:defcstruct + cffi:defcfun + cffi:foreign-slot-value + cffi:with-foreign-object + cffi:foreign-type-size + cffi:mem-ref + cffi:inc-pointer)) diff --git a/util/sdl-fonts/sdl-fonts.asd b/util/sdl-fonts/sdl-fonts.asd new file mode 100644 index 0000000..92e3991 --- /dev/null +++ b/util/sdl-fonts/sdl-fonts.asd @@ -0,0 +1,12 @@ +;;;; sdl-fonts.asd + +(asdf:defsystem #:sdl-fonts + :serial t + :description "SDL-based TTF font rendering for StumpWM." + :version "1.0.0" + :author "Mihail Ivanchev " + :license "MIT" + :depends-on (#:stumpwm #:cffi #:cffi-libffi) + :components ((:file "package") + (:file "sdl-fonts"))) + diff --git a/util/sdl-fonts/sdl-fonts.lisp b/util/sdl-fonts/sdl-fonts.lisp new file mode 100644 index 0000000..b32ba61 --- /dev/null +++ b/util/sdl-fonts/sdl-fonts.lisp @@ -0,0 +1,270 @@ +;;;; sdl-fonts.lisp + +(in-package #:sdl-fonts) + +(export '(load-font + font-exists-p + open-font + close-font + font-ascent + font-descent + font-height + text-line-width + draw-image-glyphs)) + +(define-foreign-library libsdl2 + (:unix (:or "libSDL2-2.0.so.0" "libSDL2.so.0.2" "libSDL2"))) + +(define-foreign-library libsdl2-ttf + (:unix (:or "libSDL2_ttf-2.0.so.0" "libSDL2_ttf"))) + +(use-foreign-library libsdl2) +(use-foreign-library libsdl2-ttf) + +(defcstruct sdl-rect + (x :int) + (y :int) + (w :int) + (h :int)) + +(defcstruct sdl-surface + (flags :uint32) + (format :pointer) + (w :int) + (h :int) + (pitch :int) + (pixels :pointer) + (userdata :pointer) + (locked :int) + (list-bitmap :pointer) + (clip-rect (:struct sdl-rect)) + (map :pointer) + (refcount :int)) + +(defcstruct sdl-color + (r :uint8) + (g :uint8) + (b :uint8) + (a :uint8)) + +; Using :compile-toplevel because the var is used in a declare type statement. +(eval-when (:compile-toplevel :load-toplevel) + (defvar *hinting-flags* '(:normal :light :mono :none :light-subpixel))) + +(deftype hinting-mode () `(member ,@*hinting-flags*)) + +(defcfun "SDL_Init" :int (flags :long)) +(defcfun "SDL_WasInit" :int (flags :long)) +(defcfun "SDL_LockSurface" :void (surf :pointer)) +(defcfun "SDL_UnlockSurface" :void (surf :pointer)) +(defcfun "SDL_FreeSurface" :void (surf :pointer)) +(defcfun "TTF_Init" :int) +(defcfun "TTF_WasInit" :int) +(defcfun "TTF_OpenFont" :pointer (file :string) (ptsize :int)) +(defcfun "TTF_SizeUTF8" :int (font :pointer) + (text :string) + (w :pointer) + (h :pointer)) +(defcfun "TTF_RenderUTF8_Blended" :pointer + (font :pointer) + (text :string) + (fg (:struct sdl-color))) +(defcfun "TTF_FontAscent" :int (font :pointer)) +(defcfun "TTF_FontDescent" :int (font :pointer)) +(defcfun "TTF_FontHeight" :int (font :pointer)) +(defcfun "TTF_SetFontSizeDPI" :int (font :pointer) + (ptsize :int) + (hdpi :unsigned-int) + (vdpi :unsigned-int)) +(defcfun "TTF_SetFontHinting" :int (font :pointer) (hinting :int)) +(defcfun "TTF_SetFontKerning" :int (font :pointer) (allowed :int)) + +(defclass font () + ((sdl2-ptr + :initarg :sdl2-ptr + :accessor sdl2-ptr) + (size + :initarg :size + :accessor font-size) + (hdpi + :initform nil + :accessor font-hdpi) + (vdpi + :initform nil + :accessor font-vdpi))) + +(defconstant SDL_INIT_VIDEO #x00000020) + +(defun load-font (path size &key hinting (kerning t kerning-p)) + (declare (type (or null hinting-mode) hinting)) + (when (zerop (sdl-wasinit SDL_INIT_VIDEO)) + (sdl-init SDL_INIT_VIDEO)) + (when (zerop (ttf-wasinit)) + (ttf-init)) + (let ((font (make-instance 'font + :sdl2-ptr (ttf-openfont path size) + :size size))) + (when hinting + (ttf-setfonthinting (sdl2-ptr font) + (position hinting *hinting-flags*))) + (when kerning-p + (ttf-setfontkerning (sdl2-ptr font) + (if kerning 1 0))) + font)) + +(defmethod font-exists-p ((font font)) + t) + +(defmethod open-font (display (font font)) + font) + +(defmethod close-font ((font font)) + t) + +(defmethod font-ascent ((font font)) + (ttf-fontascent (sdl2-ptr font))) + +(defmethod font-descent ((font font)) + (ttf-fontdescent (sdl2-ptr font))) + +(defmethod font-height ((font font)) + (ttf-fontheight (sdl2-ptr font))) + +(defun get-destination-picture (drawable) + (or (getf (xlib:drawable-plist drawable) :ttf-surface) + (setf (getf (xlib:drawable-plist drawable) :ttf-surface) + (xlib:render-create-picture + drawable + :format (first (xlib::find-matching-picture-formats (xlib:drawable-display drawable) + :depth (xlib:drawable-depth drawable))))))) +(defun get-source-pixmap (drawable) + (or (getf (xlib:drawable-plist drawable) :ttf-pen-surface) + (setf (getf (xlib:drawable-plist drawable) :ttf-pen-surface) + (xlib:create-pixmap + :drawable drawable + :depth (xlib:drawable-depth drawable) + :width 1 :height 1)))) + +(defun get-source-picture (drawable) + (or (getf (xlib:drawable-plist drawable) :ttf-pen) + (setf (getf (xlib:drawable-plist drawable) :ttf-pen) + (xlib:render-create-picture + (get-source-pixmap drawable) + :format (first (xlib::find-matching-picture-formats (xlib:drawable-display drawable) + :depth (xlib:drawable-depth drawable))) + :repeat :on)))) + +(defun display-alpha-picture-format (display) + (or (getf (xlib:display-plist display) :ttf-alpha-format) + (setf (getf (xlib:display-plist display) :ttf-alpha-format) + (first + (xlib:find-matching-picture-formats + display + :depth 8 :alpha 8 :red 0 :blue 0 :green 0))))) + +(defun drawable-screen (drawable) + (typecase drawable + (xlib:drawable + (dolist (screen (xlib:display-roots (xlib:drawable-display drawable))) + (when (xlib:drawable-equal (xlib:screen-root screen) (xlib:drawable-root drawable)) + (return screen)))) + (xlib:screen drawable) + (t nil))) + +(defun screen-default-dpi (screen) + "Returns default dpi for @var{screen}. pixel width * 25.4/millimeters width" + (values (floor (* (xlib:screen-width screen) 25.4) + (xlib:screen-width-in-millimeters screen)) + (floor (* (xlib:screen-height screen) 25.4) + (xlib:screen-height-in-millimeters screen)))) + +(defun update-dpi (font drawable) + (multiple-value-bind (hdpi vdpi) (screen-default-dpi (drawable-screen drawable)) + (when (or (not (eq (font-hdpi font) hdpi)) + (not (eq (font-vdpi font) vdpi))) + (ttf-setfontsizedpi (sdl2-ptr font) (font-size font) hdpi vdpi) + (setf (font-hdpi font) hdpi) + (setf (font-vdpi font) vdpi)))) + +(defmethod text-line-width ((font font) text &rest keys &key (start 0) end translate) + (declare (ignorable keys start end translate)) + (with-foreign-object (sizes :int 2) + (ttf-sizeutf8 + (sdl2-ptr font) + text + sizes + (inc-pointer sizes (foreign-type-size :int))) + (mem-ref sizes :int 0))) + +(defmethod draw-image-glyphs (drawable + gcontext + (font font) + x y + text &rest keys + &key (start 0) end translate width size) + (declare (ignorable keys start end translate width size)) + (when (string= text "") + (return-from draw-image-glyphs)) + ; Update the DPI in case it has changed (i.e. rendering to another screen). + (update-dpi font drawable) + ; This is ugly code but the idea is that we don't really know anything about + ; the color format etc. of the thing we are drawing on (i.e. the screen). So + ; we use the alpha channel of the rendered glyphs to stencil out a rectangle + ; in the foreground color onto a rectangle of the background color. This is + ; the only way to properly handle all possible cases. + (let* ((surf (ttf-renderutf8-blended + (sdl2-ptr font) + text + '(r 0 b 0 g 0 a 0))) + (width (foreign-slot-value surf '(:struct sdl-surface) 'w)) + (height (foreign-slot-value surf '(:struct sdl-surface) 'h)) + (pitch (foreign-slot-value surf '(:struct sdl-surface) 'pitch)) + (data (make-array (list height width) :element-type '(unsigned-byte 8)))) + (sdl-locksurface surf) + (let ((pixels (foreign-slot-value surf '(:struct sdl-surface) 'pixels))) + (dotimes (jj height) + (dotimes (ii width) + (let ((alpha (mem-ref pixels :uint8 (+ (* jj pitch) (* ii 4) 3)))) + (setf (aref data jj ii) alpha))))) + (sdl-unlocksurface surf) + (sdl-freesurface surf) + (let* ((display (xlib:drawable-display drawable)) + (image (xlib:create-image + :depth 8 + :width width + :height height + :data data)) + (alpha-pixmap (xlib:create-pixmap :width width + :height height + :depth 8 + :drawable drawable)) + (alpha-gc (xlib:create-gcontext :drawable alpha-pixmap)) + (alpha-pic + (progn + (xlib:put-image alpha-pixmap alpha-gc image :x 0 :y 0) + (xlib:render-create-picture alpha-pixmap + :format (display-alpha-picture-format display)))) + (src-pic (get-source-picture drawable)) + (dst-pic (get-destination-picture drawable))) + (xlib:free-gcontext alpha-gc) + ; Paint the source & destination surfaces in the foreground and + ; background colors of the context. + (xlib:draw-point (get-source-pixmap drawable) gcontext 0 0) + (let ((fg (xlib:gcontext-foreground gcontext))) + (setf (xlib:gcontext-foreground gcontext) (xlib:gcontext-background gcontext)) + (xlib:draw-rectangle drawable gcontext x (- y (font-ascent font)) width height t) + (setf (xlib:gcontext-foreground gcontext) fg)) + (xlib:render-composite :over + src-pic + alpha-pic + dst-pic + 0 + 0 + 0 + 0 + x + (- y (font-ascent font)) + width + height) + (xlib:render-free-picture alpha-pic) + (xlib:free-pixmap alpha-pixmap)))) From 170622b0174f33a02c9e96f771fac9ae756c4d77 Mon Sep 17 00:00:00 2001 From: Mihail Ivanchev Date: Sat, 19 Apr 2025 13:19:07 +0200 Subject: [PATCH 2/2] Adding error handling for SDL errors. --- util/sdl-fonts/package.lisp | 1 + util/sdl-fonts/sdl-fonts.lisp | 182 ++++++++++++++++++---------------- 2 files changed, 100 insertions(+), 83 deletions(-) diff --git a/util/sdl-fonts/package.lisp b/util/sdl-fonts/package.lisp index 100d28b..6f84a2e 100644 --- a/util/sdl-fonts/package.lisp +++ b/util/sdl-fonts/package.lisp @@ -20,5 +20,6 @@ cffi:foreign-slot-value cffi:with-foreign-object cffi:foreign-type-size + cffi:null-pointer-p cffi:mem-ref cffi:inc-pointer)) diff --git a/util/sdl-fonts/sdl-fonts.lisp b/util/sdl-fonts/sdl-fonts.lisp index b32ba61..122a37b 100644 --- a/util/sdl-fonts/sdl-fonts.lisp +++ b/util/sdl-fonts/sdl-fonts.lisp @@ -54,28 +54,30 @@ (deftype hinting-mode () `(member ,@*hinting-flags*)) (defcfun "SDL_Init" :int (flags :long)) +(defcfun "SDL_Quit" :void) (defcfun "SDL_WasInit" :int (flags :long)) (defcfun "SDL_LockSurface" :void (surf :pointer)) (defcfun "SDL_UnlockSurface" :void (surf :pointer)) (defcfun "SDL_FreeSurface" :void (surf :pointer)) +(defcfun "SDL_GetError" :string) (defcfun "TTF_Init" :int) +(defcfun "TTF_Quit" :void) (defcfun "TTF_WasInit" :int) (defcfun "TTF_OpenFont" :pointer (file :string) (ptsize :int)) (defcfun "TTF_SizeUTF8" :int (font :pointer) (text :string) (w :pointer) (h :pointer)) -(defcfun "TTF_RenderUTF8_Blended" :pointer - (font :pointer) - (text :string) - (fg (:struct sdl-color))) +(defcfun "TTF_RenderUTF8_Blended" :pointer (font :pointer) + (text :string) + (fg (:struct sdl-color))) (defcfun "TTF_FontAscent" :int (font :pointer)) (defcfun "TTF_FontDescent" :int (font :pointer)) (defcfun "TTF_FontHeight" :int (font :pointer)) (defcfun "TTF_SetFontSizeDPI" :int (font :pointer) - (ptsize :int) - (hdpi :unsigned-int) - (vdpi :unsigned-int)) + (ptsize :int) + (hdpi :unsigned-int) + (vdpi :unsigned-int)) (defcfun "TTF_SetFontHinting" :int (font :pointer) (hinting :int)) (defcfun "TTF_SetFontKerning" :int (font :pointer) (allowed :int)) @@ -97,20 +99,35 @@ (defun load-font (path size &key hinting (kerning t kerning-p)) (declare (type (or null hinting-mode) hinting)) - (when (zerop (sdl-wasinit SDL_INIT_VIDEO)) - (sdl-init SDL_INIT_VIDEO)) - (when (zerop (ttf-wasinit)) - (ttf-init)) - (let ((font (make-instance 'font - :sdl2-ptr (ttf-openfont path size) - :size size))) - (when hinting - (ttf-setfonthinting (sdl2-ptr font) - (position hinting *hinting-flags*))) - (when kerning-p - (ttf-setfontkerning (sdl2-ptr font) - (if kerning 1 0))) - font)) + (let ((sdl-initialized nil) + (ttf-initialized nil)) + (when (zerop (sdl-wasinit SDL_INIT_VIDEO)) + (if (zerop (sdl-init SDL_INIT_VIDEO)) + (setf sdl-initialized t) + (error (sdl-geterror)))) + (when (zerop (ttf-wasinit)) + (if (zerop (ttf-init)) + (setf ttf-initialized t) + (let ((err (sdl-geterror))) + (when sdl-initialized + (sdl-quit)) + (error err)))) + (let ((ptr (ttf-openfont path size))) + (when (null-pointer-p ptr) + (let ((err (sdl-geterror))) + (when ttf-initialized + (ttf-quit)) + (when sdl-initialized + (sdl-quit)) + (error err))) + (let ((font (make-instance 'font :sdl2-ptr ptr :size size))) + (when hinting + (ttf-setfonthinting (sdl2-ptr font) + (position hinting *hinting-flags*))) + (when kerning-p + (ttf-setfontkerning (sdl2-ptr font) + (if kerning 1 0))) + font)))) (defmethod font-exists-p ((font font)) t) @@ -189,12 +206,12 @@ (defmethod text-line-width ((font font) text &rest keys &key (start 0) end translate) (declare (ignorable keys start end translate)) (with-foreign-object (sizes :int 2) - (ttf-sizeutf8 - (sdl2-ptr font) - text - sizes - (inc-pointer sizes (foreign-type-size :int))) - (mem-ref sizes :int 0))) + (if (zerop (ttf-sizeutf8 (sdl2-ptr font) + text + sizes + (inc-pointer sizes (foreign-type-size :int)))) + (mem-ref sizes :int 0) + (error (sdl-geterror))))) (defmethod draw-image-glyphs (drawable gcontext @@ -212,59 +229,58 @@ ; we use the alpha channel of the rendered glyphs to stencil out a rectangle ; in the foreground color onto a rectangle of the background color. This is ; the only way to properly handle all possible cases. - (let* ((surf (ttf-renderutf8-blended - (sdl2-ptr font) - text - '(r 0 b 0 g 0 a 0))) - (width (foreign-slot-value surf '(:struct sdl-surface) 'w)) - (height (foreign-slot-value surf '(:struct sdl-surface) 'h)) - (pitch (foreign-slot-value surf '(:struct sdl-surface) 'pitch)) - (data (make-array (list height width) :element-type '(unsigned-byte 8)))) - (sdl-locksurface surf) - (let ((pixels (foreign-slot-value surf '(:struct sdl-surface) 'pixels))) - (dotimes (jj height) - (dotimes (ii width) - (let ((alpha (mem-ref pixels :uint8 (+ (* jj pitch) (* ii 4) 3)))) - (setf (aref data jj ii) alpha))))) - (sdl-unlocksurface surf) - (sdl-freesurface surf) - (let* ((display (xlib:drawable-display drawable)) - (image (xlib:create-image - :depth 8 - :width width - :height height - :data data)) - (alpha-pixmap (xlib:create-pixmap :width width - :height height - :depth 8 - :drawable drawable)) - (alpha-gc (xlib:create-gcontext :drawable alpha-pixmap)) - (alpha-pic - (progn - (xlib:put-image alpha-pixmap alpha-gc image :x 0 :y 0) - (xlib:render-create-picture alpha-pixmap - :format (display-alpha-picture-format display)))) - (src-pic (get-source-picture drawable)) - (dst-pic (get-destination-picture drawable))) - (xlib:free-gcontext alpha-gc) - ; Paint the source & destination surfaces in the foreground and - ; background colors of the context. - (xlib:draw-point (get-source-pixmap drawable) gcontext 0 0) - (let ((fg (xlib:gcontext-foreground gcontext))) - (setf (xlib:gcontext-foreground gcontext) (xlib:gcontext-background gcontext)) - (xlib:draw-rectangle drawable gcontext x (- y (font-ascent font)) width height t) - (setf (xlib:gcontext-foreground gcontext) fg)) - (xlib:render-composite :over - src-pic - alpha-pic - dst-pic - 0 - 0 - 0 - 0 - x - (- y (font-ascent font)) - width - height) - (xlib:render-free-picture alpha-pic) - (xlib:free-pixmap alpha-pixmap)))) + (let ((surf (ttf-renderutf8-blended (sdl2-ptr font) text '(r 0 b 0 g 0 a 0)))) + (when (null-pointer-p surf) + (error (sdl-geterror))) + (let* ((width (foreign-slot-value surf '(:struct sdl-surface) 'w)) + (height (foreign-slot-value surf '(:struct sdl-surface) 'h)) + (pitch (foreign-slot-value surf '(:struct sdl-surface) 'pitch)) + (data (make-array (list height width) :element-type '(unsigned-byte 8)))) + (sdl-locksurface surf) + (let ((pixels (foreign-slot-value surf '(:struct sdl-surface) 'pixels))) + (dotimes (jj height) + (dotimes (ii width) + (let ((alpha (mem-ref pixels :uint8 (+ (* jj pitch) (* ii 4) 3)))) + (setf (aref data jj ii) alpha))))) + (sdl-unlocksurface surf) + (sdl-freesurface surf) + (let* ((display (xlib:drawable-display drawable)) + (image (xlib:create-image + :depth 8 + :width width + :height height + :data data)) + (alpha-pixmap (xlib:create-pixmap :width width + :height height + :depth 8 + :drawable drawable)) + (alpha-gc (xlib:create-gcontext :drawable alpha-pixmap)) + (alpha-pic + (progn + (xlib:put-image alpha-pixmap alpha-gc image :x 0 :y 0) + (xlib:render-create-picture alpha-pixmap + :format (display-alpha-picture-format display)))) + (src-pic (get-source-picture drawable)) + (dst-pic (get-destination-picture drawable))) + (xlib:free-gcontext alpha-gc) + ; Paint the source & destination surfaces in the foreground and + ; background colors of the context. + (xlib:draw-point (get-source-pixmap drawable) gcontext 0 0) + (let ((fg (xlib:gcontext-foreground gcontext))) + (setf (xlib:gcontext-foreground gcontext) (xlib:gcontext-background gcontext)) + (xlib:draw-rectangle drawable gcontext x (- y (font-ascent font)) width height t) + (setf (xlib:gcontext-foreground gcontext) fg)) + (xlib:render-composite :over + src-pic + alpha-pic + dst-pic + 0 + 0 + 0 + 0 + x + (- y (font-ascent font)) + width + height) + (xlib:render-free-picture alpha-pic) + (xlib:free-pixmap alpha-pixmap)))))