;;; -*- Mode:LISP; Package:TIGER; Base:8; Readtable:T -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

(defvar wind (make-instance 'tv:window :label nil :inside-size '(60. 30.)))

(defun make-ch (array col first-row)
  (dpb (ar-2-reverse array col first-row) 501
       (dpb (ar-2-reverse array col (1+ first-row)) 401
	    (dpb (ar-2-reverse array col (+ 2 first-row)) 301
		 (dpb (ar-2-reverse array col (+ 3 first-row)) 201
		      (dpb (ar-2-reverse array col (+ 4 first-row)) 101
			   (dpb (ar-2-reverse array col (+ 5 first-row)) 001 0)))))))

(defsubst get-font (font)
  (if (typep font 'font) font (symeval font)))

(defun slashify-tyo (ch stream)
  (selectq ch
    ((#// #/" #/) (send stream :tyo #//) (send stream :tyo ch))
    (t (send stream :tyo ch))))

(defun write-character-strings (font &optional (stream standard-output)
				(window wind)
				(start 0)
				(end 127.))
  (let ((a (send window :screen-array))
	(fon (get-font font)))
    (send window :expose)
    (send window :set-font-map (list fonts:25fg fon))
    (send window :set-current-font 1)
    (format stream "~% (")
    (multiple-value-bind (left top right bottom)
	(send window :inside-edges)
      right
      bottom
      (loop with exists-table = (font-chars-exist-table fon)
	    with width = (font-char-width fon)
	    with width-table = (font-char-width-table fon)
	    for char from start to end
	    when (or (null exists-table) (eq (aref exists-table char) 1))
	      do (when width-table
		   (unless (aref width-table char)
		     (aset width width-table char)))
	         (send window :clear-screen)
		 (send window :tyo char)
		 (format stream "~%  #//~C /"" char)
		 (loop for col from left below (+ left (if width-table 
							   (or (aref width-table char) width)
							 width))
		       do (slashify-tyo (make-ch a col top) stream)
		          (slashify-tyo (make-ch a col (+ top 6)) stream)
			  (slashify-tyo (make-ch a col (+ top 12.)) stream)
			  (slashify-tyo (make-ch a col (+ top 18.)) stream))
		 (format stream "/""))
      (format stream ")~%"))))

(defun write-toshiba-font (font &optional (directory "sys:tiger;toshiba-fonts;"))
  (let ((font-name (font-name (get-font font))))
    (with-open-file (stream (send (fs:merge-pathname-defaults directory) :new-pathname
				  :name (string font-name)
				  :type "lisp")
			    :direction :output)
      (format stream ";;; -*- Mode:Lisp; Package:Tiger; Base:8;readtable:t -*-~%")
      (format stream
	      "~%(setq tiger:~A (stuff-toshiba-font /"~A/" '" font-name font-name)
      (write-character-strings font stream)
      (format stream " ))~%"))))

(defun stuff-toshiba-font (name char-list)
  (loop with arr = (make-toshiba-font :name name)
	for (ch str) on char-list by #'cddr
	do (aset str arr ch)
	finally (return arr)))