mirror of
https://github.com/stumpwm/stumpwm-contrib.git
synced 2026-09-10 07:26:25 -04:00
290 lines
11 KiB
Common Lisp
290 lines
11 KiB
Common Lisp
;;;; 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_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_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))
|
|
(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)
|
|
|
|
(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 (eql (font-hdpi font) hdpi))
|
|
(not (eql (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)
|
|
(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
|
|
(font font)
|
|
x y
|
|
text &rest keys
|
|
&key (start 0) end translate width size)
|
|
(declare (ignorable keys start end translate width size))
|
|
(declare (optimize (safety 0) (speed 3)))
|
|
(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))))
|
|
(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)
|
|
; Calculate an offset to the first element of the current row.
|
|
(let ((offset (+ 3 (* jj pitch))))
|
|
(dotimes (ii width)
|
|
(let ((alpha (mem-ref pixels :uint8 (+ offset (* ii 4)))))
|
|
(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)))))
|