Skip to content
This repository
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

executable file 99 lines (71 sloc) 3.438 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|

Celtk -- Cells, Tcl, and Tk

Copyright (C) 2006 by Kenneth Tilton

This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

See the Lisp Lesser GNU Public License for more details.

|#

(in-package :celtk)

;;; --- fonts obtained from Tk-land ---------------

(eval-now!
  (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent tkfinfo-linespace tkfinfo-fixed
             tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent
             tkfinfo-descent ^tkfont-descent ^tkfont-find
             tkfinfo tkfinfo-em ^tkfont-em
             line-up line-down tkfont-size-info)))

(defmacro def^macros (&rest fn-names)
  `(progn ,@(loop for fn-name in fn-names
                  collecting (let ((^name (format nil "^~:@(~a~)" fn-name)))
                               `(progn
                                  (eval-now!
                                    (export '(,(intern ^name))))
                                  (defmacro ,(intern ^name) ()
                                    `(,',fn-name self)))))))

(def^macros line-up line-down tkfont-height tkfont-ascent tkfinfo-descent)

(defstruct tkfinfo id family size slant ascent descent linespace fixed em)

(deftk tkfont (widget)
  ()
  (:tk-spec font
    -family -size -weight -slant -underline -overstrike)
  (:default-initargs
      :id (gentemp "fnt")))

(defmethod make-tk-instance ((self tkfont))
  (setf (gethash (^path) (dictionary .tkw)) self)
  (tk-format `(:make-tk ,self) "font create ~a ~{~(~a~) ~a~^ ~}"
      (tkfont-id self)(tk-configurations self)))

(defmethod tk-configure ((self tkfont) option value)
  (tk-format `(:configure ,self ,option) "font configure ~(~a~) ~(~a~) ~a"
    (path self) option (tk-send-value value)))

(defun tkfont-id (tkfont) (md-name tkfont))

(defmethod path ((self tkfont))
  (tkfont-id self))

(defmacro ^tkfont-find (tkfont-id)
  `(cdr (assoc ,tkfont-id (tkfont-info .tkw))))
      
(defmodel tkfontified ()
  ((fkey :initarg :fkey :accessor fkey :initform nil)
   (f-size-step :initarg :f-size-step :accessor f-size-step
     :initform 0)
   (tkfinfo :initarg :tkfinfo :accessor tkfinfo
     :initform (c_? (bwhen (fkey (^fkey))
                       (let ((fkey-table (cdr (assoc fkey (tkfont-info .tkw)))))
                         (assert fkey-table () "no such tkfont: ~a ~a" fkey (symbol-package fkey))
                         (svref fkey-table (^f-size-step)))))))
  (:default-initargs
      :tkfont (c_? (bwhen (fi (^tkfinfo))
                  (tkfinfo-id fi)))))

(defun tkfont-size-info (self tkfont decrements)
  (let ((tkfont-size-table (cdr (assoc tkfont (tkfont-info .tkw)))))
    (assert tkfont-size-table () "no such tkfont: ~a ~a" tkfont (symbol-package tkfont))
    (svref tkfont-size-table (+ 2 decrements)))) ;; we allow -decrements as a guess that it will be needed. dumb. :)

(defun tkfont-ascent (self)
  (tkfinfo-ascent (^tkfinfo)))

(defun tkfont-height (self)
  (tkfinfo-linespace (^tkfinfo)))

(defun line-up (self)
  (ceiling (tkfont-height self) -2))

(defun line-down (self)
  (floor (tkfont-height self) 2))



Something went wrong with that request. Please try again.