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

;;; The routine

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

(defvar *wind* nil)

(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 (or *wind*
					    (setq *wind*
						  (make-instance 'tv:window :label nil :inside-size '(60. 30.)))))
				(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 (get :toshiba 'font-directory)))
  "This converts the lispmachine font FONT into a toshiba format font source
You then might want to QC-FILE that file."
  ;; this should go direct to QFASL but I dont want to bother rewriting it.
  (let* ((font-name (font-name (get-font font)))
	 (file-name (send (fs:merge-pathname-defaults directory) :new-pathname
				  :name (string font-name)
				  :TYPE "LISP"
				  :VERSION :NEWEST)))
    (with-open-file (stream file-name :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 " ))~%"))
    file-name))

(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)))