font.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :Celtk)
  20
  21 ;;; --- fonts obtained from Tk-land ---------------
  22
  23 (eval-now!
  24   (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent  tkfinfo-linespace tkfinfo-fixed
  25              tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent
  26              tkfinfo-descent ^tkfont-descent ^tkfont-find
  27              tkfinfo tkfinfo-em ^tkfont-em
  28              line-up line-down tkfont-size-info)))
  29
  30 (defmacro def^macros (&rest fn-names)
  31   `(progn ,@(loop for fn-name in fn-names
  32                   collecting (let ((^name (format nil "^~:@(~a~)" fn-name)))
  33                                `(progn
  34                                   (eval-now!
  35                                     (export '(,(intern ^name))))
  36                                   (defmacro ,(intern ^name) ()
  37                                     `(,',fn-name self)))))))
  38
  39 (def^macros line-up line-down tkfont-height tkfont-ascent tkfinfo-descent)
  40
  41 (defstruct tkfinfo id family size slant ascent descent linespace fixed em)
  42
  43 (deftk tkfont (widget)
  44   ()
  45   (:tk-spec font
  46     -family -size -weight -slant -underline -overstrike)
  47   (:default-initargs
  48       :id (gentemp "fnt")))
  49
  50 (defmethod make-tk-instance ((self tkfont))
  51   (setf (gethash (^path) (dictionary .tkw)) self)
  52   (tk-format `(:make-tk ,self) "font create ~a ~{~(~a~) ~a~^ ~}"
  53       (tkfont-id self)(tk-configurations self)))
  54
  55 (defmethod tk-configure ((self tkfont) option value)
  56   (tk-format `(:configure ,self ,option) "font configure ~(~a~) ~(~a~) ~a"
  57     (path self) option (tk-send-value value)))
  58
  59 (defun tkfont-id (tkfont) (md-name tkfont))
  60
  61 (defmethod path ((self tkfont))
  62   (tkfont-id self))
  63
  64 (defmacro ^tkfont-find (tkfont-id)
  65   `(cdr (assoc ,tkfont-id (tkfont-info .tkw))))
  66
  67 (defmodel tkfontified ()
  68   ((fkey :initarg :fkey :accessor fkey :initform nil)
  69    (f-size-step :initarg :f-size-step :accessor f-size-step
  70      :initform 0)
  71    (tkfinfo :initarg :tkfinfo :accessor tkfinfo
  72      :initform (c_? (bwhen (fkey (^fkey))
  73                        (let ((fkey-table (cdr (assoc fkey (tkfont-info .tkw)))))
  74                          (ASSERT fkey-table () "no such tkfont: ~a ~a" fkey (symbol-package fkey))
  75                          (svref fkey-table (^f-size-step)))))))
  76   (:default-initargs
  77       :tkfont (c_? (bwhen (fi (^tkfinfo))
  78                   (tkfinfo-id fi)))))
  79
  80 (defun tkfont-size-info (self tkfont decrements)
  81   (let ((tkfont-size-table (cdr (assoc tkfont (tkfont-info .tkw)))))
  82     (ASSERT tkfont-size-table () "no such tkfont: ~a ~a" tkfont (symbol-package tkfont))
  83     (svref tkfont-size-table (+ 2 decrements)))) ;; we allow -decrements as a guess that it will be needed. dumb. :)
  84
  85 (defun tkfont-ascent (self)
  86   (tkfinfo-ascent (^tkfinfo)))
  87
  88 (defun tkfont-height (self)
  89   (tkfinfo-linespace (^tkfinfo)))
  90
  91 (defun line-up (self)
  92   (ceiling (tkfont-height self) -2))
  93
  94 (defun line-down (self)
  95   (floor (tkfont-height self) 2))
  96
  97
  98