[ltk-user] [patch] improved font support

[Daniel Herring]

Resending.

---------- Forwarded message ----------
Date: Sun, 25 Apr 2010 00:16:26 -0400 (EDT)

The attached patch was developed on
http://ltk.rplay.net/svn/branches/ltk/repl revision 224

It adds a few useful commands for manipulating fonts.
http://www.tcl.tk/man/tcl8.5/TkCmd/font.htm

Example:
(font-create :bignum
              :family :courier
              :size 30
              :weight :bold
              :slant :italic
              :underline :true
              :overstrike :true)
(configure some-canvas-text :font :bignum)


Later,
Daniel
-------------- next part --------------
From 2c233a9a11d31839bc57a1c144a551d18f508c55 Mon Sep 17 00:00:00 2001
From: D Herring <dherring at at.tentpost.dot.com>
Date: Sun, 25 Apr 2010 00:08:39 -0400
Subject: [PATCH] Improved font support

---
 ltk.lisp |   26 +++++++++++++++++++++++---
 1 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/ltk.lisp b/ltk.lisp
index 245a7f5..7fb36be 100644
--- a/ltk.lisp
+++ b/ltk.lisp
@@ -214,6 +214,10 @@ toplevel             x
            #:event-width
            #:event-height
            #:focus
+           #:font-configure
+           #:font-create
+           #:font-delete
+           #:font-metrics
            #:force-focus
            #:forget-pane
            #:format-wish
@@ -3507,15 +3511,31 @@ set y [winfo y ~a]
 
 
 ;;; font functions
+;; use {~/ltk::down/} on the font name to match itemconfigure
 
-(defun font-create (name)
-  (format-wish "senddatastring [font create {~a}]" name)
+;;(defun font-actual ...)
+
+(defun font-configure (name &key family size weight slant underline overstrike)
+  (format-wish "font configure {~/ltk::down/}~@[ -family ~a~]~@[ -size ~a~]~@[ -weight ~(~a~)~]~@[ -slant ~(~a~)~]~@[ -underline ~a~]~@[ -overstrike ~a~]"
+               name family size weight slant underline overstrike))
+
+(defun font-create (name &key family size weight slant underline overstrike)
+  (format-wish "senddatastring [font create {~/ltk::down/}~@[ -family ~a~]~@[ -size ~a~]~@[ -weight ~(~a~)~]~@[ -slant ~(~a~)~]~@[ -underline ~a~]~@[ -overstrike ~a~]]"
+               name family size weight slant underline overstrike)
   (read-data))
 
+(defun font-delete (&rest names)
+  (format-wish "font delete~{ {~/ltk::down/}~}" names))
+
+;;(defun font-families ...)
+;;(defun font-measure ...)
+
 (defun font-metrics (font)
-  (format-wish "sendpropertylist [font metrics {~a}]" font)
+  (format-wish "sendpropertylist [font metrics {~/ltk::down/}]" font)
   (read-data))
 
+;;(defun font-names ...)
+
 ;;; wm functions
 
 (defgeneric resizable (widget x y))
-- 
1.7.0.5