; -*- Mode: Lisp; Package: editor -*-

#|
= banner - 戝偒側暥帤偱暥帤楍傪弌椡偡傞

* Author:  miyamuko ((<URL:mailto:miyamuko (at) mtb.biglobe.ne.jp>))
* URL: ((<URL:http://miyamuko.s56.xrea.com/xyzzy/banner.html>))
* Version: $Id: banner.l,v 1.7 2004/08/09 14:02:59 miyamuko Exp $


== 愢柧

Unix 偵偁傞 banner 僐儅儞僪偺堏怉偱偡丅

BDF 僼僅儞僩偝偊偁傟偽擔杮岅偩傠偆偑 AA 偩傠偆偑嫄戝偵偱偒傑偡丅


== 僀儞僗僩乕儖

((<NetInstaller|URL:http://www.mirai.ne.jp/~gyo/xyzzy/ni.html>)) 偱僀儞僗僩乕儖偟偨応崌偼 3 埲崀傪丄
NetInstaller + (({ni-autoload})) 傪巊偭偰偄傞恖偼 4 埲崀偱 OK 偱偡丅

(1) 傾乕僇僀僽傪僟僂儞儘乕僪偟傑偡丅

    ((<URL:http://miyamuko.s56.xrea.com/xyzzy/archives/banner.zip>))

(2) 傾乕僇僀僽傪揥奐偟偰丄$XYZZY/site-lisp 攝壓偵僼傽僀儖傪僐僺乕偟傑偡丅

(3) ~/.xyzzy 傑偨偼 $XYZZY/site-lisp/siteinit.l 偵埲壓偺僐乕僪傪捛壛偟傑偡丅

        ;; banner
        (require "banner")

(4) 愝掕傪斀塮偝偣傞偨傔 xyzzy 傪嵞婲摦偟偰偔偩偝偄丅

    仸siteinit.l 偵婰弎偟偨応崌偵偼嵞僟儞僾偑昁梫偱偡丅

(5) BDF 僼僅儞僩傪側偵偐僀儞僗僩乕儖偟傑偡丅

(6) BDF 僼僅儞僩偵偁傢偣偰 ((<*banner-bdf-font-selecter*>)) 傪愝掕偟傑偡丅

(7) 嫄戝壔偟偨偄晹暘傪儕乕僕儑儞偵偟偰 M-x banner-region 傑偨偼
    M-x banner 偱儈僯僶僢僼傽偐傜擖椡偟偰偔偩偝偄丅


== 儕僼傽儗儞僗

=== 僐儅儞僪

--- (banner str)

    巜掕偝傟偨暥帤楍傪戝偒偔偟偰 ((<*banner-output-buffer-name*>)) 偵
    弌椡偟傑偡丅

--- (banner-region start end)

    巜掕偝傟偨儕乕僕儑儞偺暥帤楍傪戝偒偔偟偰 ((<*banner-output-buffer-name*>)) 偵
    弌椡偟傑偡丅


=== 娭悢

--- (ed::banner-internal str &optional formatter)

    巜掕偝傟偨暥帤楍傪戝偒偔偟偰 ((<*banner-output-buffer-name*>)) 偵
    弌椡偟傑偡丅

    徣棯壜擻側戞2堷悢偵偼埲壓偺弌椡娭悢傪巜掕偟傑偡丅
    僨僼僅儖僩偼 (({ed::banner-output-horizontally})) 偱偡丅

--- (ed::banner-output-vertically glyphs)

    廲彂偒偱 banner 傪弌椡偟傑偡丅
    (({ed::banner-internal})) 偺堷悢偵巜掕偟傑偡丅

--- (ed::banner-output-horizontally glyphs)

    墶彂偒偱 banner 傪弌椡偟傑偡丅
    (({ed::banner-internal})) 偺堷悢偵巜掕偟傑偡丅


=== 曄悢

--- *bdf-directory-list*

    BDF 僼僅儞僩傪抲偄偰偍偔僨傿儗僋僩儕傪巜掕偟傑偡丅
    僨僼僅儖僩偼 $XYZZY/fonts/bdf 偱偡丅

        ;; Meadow 偝傫偺 font directory 傪捛壛
        (pushnew "D:/Tools/Meadow/fonts/bdf" *bdf-directory-list*)

--- *banner-output-buffer-name*

    弌椡僶僢僼傽偺柤慜傪偟偰偄傑偡丅

--- *banner-font-fg-char*
--- *banner-font-bg-char*

    偦傟偧傟僼僅儞僩傪宍惉偡傞暥帤偲攚宨傪愝掕偟傑偡丅

        ;; 巐妏偱儗僀傾僂僩偡傞
        (setf *banner-font-fg-char* "仭")
        (setf *banner-font-bg-char* "仩")

    偙偆側傞

        仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩
        仭仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩
        仭仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩
        仭仩仭仭仩仩仩仭仭仭仩仩仭仩仭仭仩仩仭仩仭仭仩仩仩仭仭仭仩仩仭仩仭仩
        仭仭仩仩仭仩仭仩仩仩仭仩仭仭仩仩仭仩仭仭仩仩仭仩仭仩仩仩仭仩仭仭仩仩
        仭仩仩仩仭仩仩仩仩仭仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩
        仭仩仩仩仭仩仩仭仭仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仭仭仭仭仩仭仩仩仩
        仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩仩仩仭仩仩仩
        仭仭仩仩仭仩仭仩仩仭仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仭仩仩仩
        仭仩仭仭仩仩仩仭仭仩仭仩仭仩仩仩仭仩仭仩仩仩仭仩仩仭仭仭仩仩仭仩仩仩
        仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩
        仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩仩

--- *banner-bdf-font-selecter*

    偁傞暥帤偵懳墳偡傞 BDF 僼僅儞僩偺僼傽僀儖柤傪曉偡
    娭悢傪愝掕偟傑偡丅

    ((*偙偺曄悢偼昁偢愝掕偟偰偔偩偝偄丅*))

        ;; monafont 傪棙梡偡傞
        (setf *banner-bdf-font-selecter*
              #'(lambda (c)
                  (cond ((kanji-char-p c)
                         ; 娍帤丄傂傜偑側丄僇僞僇僫
                         "monak12.bdf")
                        ((kana-char-p c)
                         ; 偄傢備傞敿妏僇僫
                         "mona6x12r.bdf")
                        (t
                         ; 偦偺懠
                         "mona6x12a.bdf"))))

        ;; K12 傪棙梡偡傞
        (setf *banner-bdf-font-selecter*
              #'(lambda (c)
                  (cond ((kanji-char-p c)
                         ; 娍帤丄傂傜偑側丄僇僞僇僫
                         "k12x10.bdf")
                        (t
                         ; 偦偺懠
                         "k6x10.bdf"))))

    僼僅儞僩傪偙傠偙傠曄偊偨偄応崌偼僉儍僢僔儏傕徚偟偨傎偆偑偄偄偱偡丅

        ; 僉儍僢僔儏傪徚偡
        (setf ed::*bdf-glyph-cache* nil)


== 偙傟偐傜傗傞偐傕偟傟側偄偙偲

* BDF 僼僅儞僩偺 encoding 傪偪傖傫偲尒傞傛偆偵偡傞丅
  * 崱偼 sjis 寛傔懪偪偩偭偨婥偑偡傞丅
* TrueType 僼僅儞僩傕巊偊傞傛偆偵偡傞 (偟偨偄)丅
  * Win32 API 傪偑傫偽偭偰偨偨偗偽偱偒傞偐側偀...?
* ttf2bdf 偱曄姺偟偨 bdf 僼僅儞僩傕巊偊傞傛偆偵偡傞丅
  * 傓偐偟幐攕偟偨婰壇偑偡傞丅
* 僼僅儞僩偺愝掕傪傕偆彮偟傑偲傕偵偡傞丅


== 娭楢偡傞偐傕偟傟側偄儁乕僕

: BDF僼傽僀儖僼僅乕儅僢僩
    ((<URL:http://hp.vector.co.jp/authors/VA013241/font/bdf.html>))

: 儌僫乕僼僅儞僩
    ((<URL:http://monafont.sourceforge.net/>))

: (X11 傪拞怱偲偟偨)僼儕乕偺擔杮岅價僢僩儅僢僾僼僅儞僩堦棗
    ((<URL:http://kappa.allnet.ne.jp/kanou/fonts/x11bdfs.html>))


== 儔僀僙儞僗

banner 偼廋惓 BSD 儔僀僙儞僗偵婎偯偄偰棙梡壜擻偱偡丅

  Copyright (C) 2003-2004 MIYAMUKO Katsuyuki. All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:

  1 Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer as the first lines
  of this file unmodified.

  2 Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  SUCH DAMAGE.
|#

(provide "banner")
(in-package "editor")

(export '(*bdf-directory-list*
          *banner-output-buffer-name*
          *banner-font-fg-char*
          *banner-font-bg-char*
          *banner-bdf-font-selecter*
          banner
          banner-vertically
          banner-region
          banner-region-vertically))

;; ----------------------------------------------------------------------
;; variables

(defvar *bdf-directory-list*
  (list (merge-pathnames "fonts/bdf" (si::system-root))))
(defvar *banner-output-buffer-name* "*banner*")
(defvar *banner-font-fg-char* "##")
(defvar *banner-font-bg-char* "  ")
(defvar *banner-bdf-font-selecter* nil)


;; ----------------------------------------------------------------------
;; commands

(defun banner (str &optional fold-width)
  "banner: 巜掕偝傟偨暥帤楍傪 banner 壔 (墶彂偒)"
  (interactive "sBanner: \np")
  (banner-internal str fold-width))

(defun banner-vertically (str)
  "banner: 巜掕偝傟偨暥帤楍傪 banner 壔 (廲彂偒)"
  (interactive "sBanner: ")
  (banner str 1))

(defun banner-region (start end &optional fold-width)
  "banner: 巜掕偝傟偨儕乕僕儑儞偺暥帤楍傪 banner 壔 (墶彂偒)"
  (interactive "r\np")
  (if (< end start) (rotatef start end))
  (banner-internal (buffer-substring start end) fold-width))

(defun banner-region-vertically (start end)
  "banner: 巜掕偝傟偨儕乕僕儑儞偺暥帤楍傪 banner 壔 (廲彂偒)"
  (interactive "r")
  (banner-region start end 1))

;; ----------------------------------------------------------------------
;; functions

(defmacro dolist-with-progress-message ((msg var listform &optional (resultform ''nil)) &body body)
  `(let ((len (length ,listform))
         (current 0))
     (do* ((#1=#:tailvar ,listform (cdr #1#))
           (,var (car #1#) (car #1#)))
         ((null #1#) ,resultform)
       (incf current)
       (message ,msg (floor (* (/ current len) 100)))
       ,@body)))

(defun banner-internal (str fold-width)
  "banner: 巜掕偝傟偨暥帤楍傪 banner 壔"
  (unless *banner-bdf-font-selecter*
    (error "*banner-bdf-font-selecter* 傪愝掕偟偰偔偩偝偄側"))
  (long-operation
    (with-output-to-temp-buffer (*banner-output-buffer-name*)
      (dolist-with-progress-message
       ("~D %" line (split-string str #\LFD))
       (do-events)
       (banner-output (map 'list 'bdf-get-glyph line) fold-width))))
  (switch-to-buffer *banner-output-buffer-name*))

(defun banner-output (glyphs &optional fold-width)
  "banner: 僼僅儞僩傪弌椡偡傞"
  (let ((p 0)
        (glyph-len (length glyphs)))
    (unless fold-width
      (setf fold-width glyph-len))
    (while (< p glyph-len)
      (apply #'mapcar #'(lambda (&rest line)
                          (format t "~{~A~}" line)
                          (terpri))
             (subseq glyphs p (min glyph-len (+ p fold-width))))
      (incf p fold-width))))

(defun banner-dispose ()
  (interactive)
  (setf *bdf-glyph-cache* nil)
  (bdf-kill-all-buffers))

;;

(defvar *bdf-glyph-cache* nil
  "banner: 撉傒崬傫偩僼僅儞僩忣曬偺僉儍僢僔儏")

(defun bdf-get-glyph (c)
  "banner: 僉儍僢僔儏偵偁傟偽偦偺僼僅儞僩忣曬傪曉偡"
  (let ((jis-code (char-jis-code c)))
    (unless *bdf-glyph-cache*
      (setf *bdf-glyph-cache* (make-hash-table)))
    (unless (gethash jis-code *bdf-glyph-cache*)
      (setf (gethash jis-code *bdf-glyph-cache*)
            (bdf-get-glyph-internal
             (bdf-find-file (funcall *banner-bdf-font-selecter* c))
             jis-code)))
    (gethash jis-code *bdf-glyph-cache*)))

(defun bdf-get-glyph-internal (bdfbuffer jis-code)
  "banner: BDF 僼傽僀儖傪夝愅偟偰僼僅儞僩忣曬傪庢摼"
  (let ((width nil)
        (result))
    ;; setup buffer
    (set-buffer bdfbuffer)
    (goto-char (point-min))

    ;; scan glyph
    (unless (scan-buffer (format nil "^ENCODING ~D\\>" jis-code) :regexp t)
      ;; use DEFAULT_CHAR if not found.
      (if (scan-buffer "^DEFAULT_CHAR \\([0-9]+\\)\\>" :regexp t)
          (return-from bdf-get-glyph-internal
            (bdf-get-glyph bdfbuffer
                           (code-char (parse-integer (match-string 1)))))
        nil))

    ;; clipping
    (save-restriction
      (narrow-to-region (point)
                        (progn
                          (scan-buffer "^ENDCHAR\\>" :regexp t :tail t)
                          (point)))
      (goto-char (point-min))

      ;; get width
      (scan-buffer (format nil "^DWIDTH +\\([0-9]+\\) +[0-9]+" jis-code)
                   :regexp t :tail t)
      (setf width (parse-integer (match-string 1)))

      ;; get glyph info
      (scan-buffer "^BITMAP\\>" :regexp t)
      (while (and (forward-line 1)
                  (not (looking-at "^ENDCHAR\\>")))
        (push (bdf-expand-glyph width
                                (buffer-substring (progn (goto-bol) (point))
                                                  (progn (goto-eol) (point))))
              result))
      (reverse result))))

(defun bdf-expand-glyph (width hex)
  "banner: BDF Font 偺忣曬傪揥奐偡傞"
  (substitute-string
   (substitute-string
    (substring (format nil "~V,'0B" width (hex-to-int hex))
               0 width)
    "1" *banner-font-fg-char*)
   "0" *banner-font-bg-char*))

(defvar *bdf-find-file-buffers* nil
  "banner: open 偟偨 BDF font 偺 buffer")

(defun bdf-find-file (bdfname)
  "banner: 巜掕偝傟偨 BDF font 傪 font path 偐傜扵偟 buffer 偵撉傒崬傓丅
argument: 僼僅儞僩柤
return: 僼僅儞僩傪撉傒崬傫偩 buffer"
  (let ((bufname (concat " " bdfname)))
    (if (find-buffer bufname)
        (return-from bdf-find-file (find-buffer bufname)))
    (dolist (dir *bdf-directory-list*)
      (when (file-exist-p (merge-pathnames bdfname dir))
        (let ((buffer (get-buffer-create bufname)))
          (set-buffer buffer)
          (insert-file (merge-pathnames bdfname dir))
          (push buffer *bdf-find-file-buffers*) ;cache
          (return-from bdf-find-file buffer))))
    (error "BDF Font 偑側偄偱偡" bdfname)))

(defun bdf-kill-all-buffers ()
  "banner: 撉傒崬傫偩 BDF font 傪偡傋偰嶍彍偡傞丅"
  (dolist (buffer *bdf-find-file-buffers*)
    (if (member buffer (buffer-list))
        (delete-buffer buffer)))
  (setf *bdf-find-file-buffers* nil))

;; ----------------------------------------------------------------------
;; util

(defun char-jis-code (c)
  "banner: 暥帤傪 JIS 僐乕僪偵曄姺偡傞"
  (if (kanji-char-p c)
      (let ((jis (map-internal-to-jis (string c))))
        (logior (ash (char-code (char jis 3)) 8)
                (char-code (char jis 4))))
    (char-code c)))

(defun hex-to-int (hex)
  "banner: 16恑暥帤楍傪 10 恑悢抣偵偡傞"
  (let ((result 0)
        (digits (map 'list
                     #'(lambda (c)
                         (cond ((char<= #\0 c #\9)
                                (- (char-code c) (char-code #\0)))
                               ((char<= #\a (char-downcase c) #\f)
                                (+ 10 (- (char-code (char-downcase c))
                                         (char-code #\a))))))
                     hex)))
    (dolist (d digits)
      (if d (setf result (+ (ash result 4) d))))
    result))

;;
;; $Id: banner.l,v 1.7 2004/08/09 14:02:59 miyamuko Exp $
;;
