(in-package "CL-USER")
 


(defun make-reader-file (fname)
  (let ((ifstream (open fname :direction :input)))
    (let ((chq nil))
      (return-from make-reader-file #'(lambda ()
                                        (setf chq (cons (read-char ifstream nil nil) (car chq)))
                                        (if (null (car chq))
                                            (close ifstream))
                                        chq)))))


(defun make-reader-string (str)
  (let ((isstream (make-string-input-stream str)))
    (let ((chq nil))
      (return-from make-reader-string #'(lambda ()
                                          (setf chq (cons (read-char isstream nil nil) (car chq)))
                                          (if (null (car chq))
                                              (close isstream))
                                          chq)))))

; Test-area

(setq rr (make-reader-file "/home/juergen/lisp/bdfconv/ProFontWindows-10.bdf"))
(setq rrs (make-reader-string "123+287.15-33.2*48.0072206;"))


(defun lex ()
  (let ((res (car (funcall rrs))))
    (values res res)))


; help functions

(defun test-union (lis1 lis2)
  (cond ((null lis1) (values lis2 nil))
        (t (multiple-value-bind (uni sec-enlarged) (test-union (cdr lis1) lis2)
             (if (member (car lis1) lis2)
                 (values uni sec-enlarged)
               (values (cons (car lis1) uni) t))))))


(defun fold (fun lis start)
  (cond ((null (cdr lis)) (funcall fun (car lis) start))
        (t (funcall fun (car lis) (fold fun (cdr lis) start)))))

(defun listify (str)
  (map 'list #'(lambda (x) x) str))

; parser generator

(defun extract-grammar-name (args)
  (car args))

(defun is-rule-p (lis)
  (eq (car lis) 'defrule))

(defun is-lexer-p (lis)
  (eq (car lis) 'deflexer))

(defun build-prod-db (args)
  (let ((prod-db (make-hash-table)))
    (setf (gethash '&prods prod-db) (make-hash-table))
    (loop for lis in (cdr args) do
      (cond ((is-rule-p lis)    
             (process-defrule lis prod-db))
            ((is-lexer-p lis)
             (process-lexer lis prod-db)))
          finally (return prod-db))))


(defun get-bodys (entry)
  (gethash 'bodys entry))

(defun (setf get-bodys) (val entry)
  (setf (gethash 'bodys entry) val))

(defun get-infos (entry)
  (gethash 'infos entry))

(defun (setf get-infos) (val entry)
  (setf (gethash 'infos entry) val))

(defun get-prods (entry)
  (gethash 'prods entry))

(defun (setf get-prods) (val entry)
  (setf (gethash 'prods entry) val))

(defun get-firsts (entry)
  (gethash 'firsts entry))

(defun (setf get-firsts) (val entry)
  (setf (gethash 'firsts entry) val))

(defun get-follows (entry)
  (gethash 'follows entry))

(defun (setf get-follows) (val entry)
  (setf (gethash 'follows entry) val))


(defun prod-db-entry-init ()
  (let ((entry (make-hash-table)))
    (setf (get-prods entry) nil)
    (setf (get-firsts entry) nil)
    (setf (get-follows entry) nil)
    (setf (get-infos entry) nil)
    (setf (get-bodys entry) nil)
    entry))

(defun process-defrule (rule prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (setf (gethash '&non-terms prod-db)
          (union (gethash '&non-terms prod-db) (list (cadr rule))))
;    (format t "*** ~%~%")
;    (show-hash prods-t #'(lambda (x) x)) 
    (if (null (gethash (cadr rule) prods-t))
        (setf (gethash (cadr rule) prods-t) (prod-db-entry-init)))
    (setf (get-prods (gethash (cadr rule) prods-t)) 
          (cons (caddr rule) (get-prods (gethash (cadr rule) prods-t))))
    (setf (get-bodys (gethash (cadr rule) prods-t))
          (cons (cdddr rule) (get-bodys (gethash (cadr rule) prods-t))))
    (setf (gethash '&prods prod-db) prods-t)))

(defun process-lexer (lis prod-db)
  (setf (gethash '&lexer prod-db) (cadr lis)))


(defun add-firsts (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry))
                   (uni nil)
                   (sec-enlarged))
               (loop 
                for pr in prods do
                (multiple-value-setq (uni sec-enlarged) (test-union (prod-first pr ntermsym prod-db) (get-firsts entry)))
                (if sec-enlarged
                    (setf (get-infos entry) (union (list 'added) (get-infos entry))))
                (setf (get-firsts entry) uni))))
         until (null found))))))


(defun empty-term-p (x)
  (and (symbolp x) (eq x 'eps)))

(defun non-termsym-p (x prod-db)
  (and (symbolp x) (not (empty-term-p x)) (member x (gethash '&non-terms prod-db))))
 
(defun prod-first (pr ntermsym prod-db)
  (let ((pr-start (car pr)))
    (sym-first-1 pr-start ntermsym prod-db)))


(defun sym-first-1 (pr-start ntermsym prod-db)
  (cond ((symbolp pr-start)
         (cond ((empty-term-p pr-start)
                (get-follows (gethash ntermsym (gethash '&prods prod-db))))
               ((non-termsym-p pr-start prod-db) (get-firsts (gethash pr-start (gethash '&prods prod-db))))
               (t (list pr-start))))
        ((stringp pr-start)
         (list (char pr-start 0)))
        ((listp pr-start)
         (cond ((eq (car pr-start) 'choose)
                (listify (cadr pr-start)))))
        (t nil)))

        
                  
(defun firsts-added (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop
         with res-flag = nil
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (if (member 'added (get-infos entry))
                 (progn
                   (setf (get-infos entry) (remove 'added (get-infos entry)))
                   (setf res-flag t))))
         until (null found)
         finally return res-flag)))))
     

(defun follows-added (prod-db)
  (firsts-added prod-db))


(defun add-follows (prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry)))
               (loop 
                for pr in prods do
                (prod-follow pr ntermsym prod-db))))
         until (null found))))))

(defun prod-follow (pr ntermsym prod-db)
  (loop
   with pr-1 = pr
   with entry = nil
   with new-follows = nil
   with uni = nil
   with sec-enlarged = nil
   do
;   (format t "pr = ~A~%~%" pr)
   (if (non-termsym-p (car pr-1) prod-db)
       (progn
         (setf entry (gethash (car pr-1) (gethash '&prods prod-db)))
         (if (not (null (cdr pr-1)))
             (setf new-follows (sym-first-1 (cadr pr-1) 'error prod-db))
           (setf new-follows (get-follows (gethash ntermsym (gethash '&prods prod-db)))))
;         (format t "new-follows = ~A / ~A~%" new-follows (car pr-1))
         (multiple-value-setq (uni sec-enlarged) (test-union new-follows (get-follows entry)))
         (if sec-enlarged
             (setf (get-infos entry) (union (list 'added) (get-infos entry))))
         (setf (get-follows entry) uni)
         (setf (gethash (car pr-1) (gethash '&prods prod-db)) entry)))
   (setf pr-1 (cdr pr-1))
   until (null pr-1)
   finally return nil))
   



(defun compute-first-and-follow (prod-db)
  (loop 
   with firsts-a = nil
   with follows-a = nil
   do
   (add-firsts prod-db)
   (setf firsts-a (firsts-added prod-db))
   (format t "Firsts-a = ~A~%~%" firsts-a)
   (if (or firsts-a follows-a)
       (add-follows prod-db))
   (setf follows-a (follows-added prod-db))
   while (or firsts-a follows-a)
   finally (return prod-db)))


(defun check-disjoint (lis)
  (cond ((null lis) t)
        (t (and (check-disjoint (cdr lis))
                (fold #'(lambda (a b) (and (null a) b))
                      (mapcar #'(lambda (x) (intersection x (car lis))) (cdr lis)) t)))))

       
(defun check-prods (prod-db)
  (let ((is-ok t)
        (prods-t (gethash '&prods prod-db)))
    (with-hash-table-iterator (term prods-t)
      (let ((found nil)
            (ntermsym nil)
            (entry nil))
        (loop 
         do
         (multiple-value-setq (found ntermsym entry) (term))
         (if found
             (let ((prods (get-prods entry))
                   (prod-inis nil))
               (loop 
                for pr in (reverse prods) do
                (push (sym-first-1 (car pr) ntermsym prod-db) prod-inis))
               (if (not (check-disjoint prod-inis))
                   (setf is-ok nil))
               (setf (get-infos entry) (union (get-infos entry) (list (list 'prod-inis prod-inis))))))
         until (null found))))
    is-ok))
  

(defun build-parser (prod-db)
  (let ((non-term-list (gethash '&non-terms prod-db))
        (labels-defuns nil)
        (res nil))
    (setf labels-defuns
          (loop
           with res = nil
           for nterm in non-term-list do
           (push (compile-nt-sym nterm prod-db) res)
           finally
           return res))
    (setf res
          (list 'labels labels-defuns 
                `(multiple-value-bind (insym insym-val) (funcall lexer)
;                   (format t "insym = ~A * insym-val = ~A~%" insym insym-val)
                   (S insym insym-val lexer))))))

(defun get-prod-inis (nterm prod-db)
  (let ((prods-t (gethash '&prods prod-db)))
    (let ((nterm-infos (get-infos (gethash nterm prods-t))))
      (cadr (find 'prod-inis nterm-infos :key #'(lambda (x) (car x)))))))
      

(defun compile-nt-sym (nterm prod-db)
  (let ((prod-inis (get-prod-inis nterm prod-db))
        (lexer-fun 'lex))
    (list nterm (list 'insym 'insym-val lexer-fun)
          (cons 'cond
                (mapcar #'(lambda (x y z) (list (list 'member 'insym (list 'quote x)) (compile-prod y z lexer-fun prod-db)))
                        prod-inis
                        (get-prods (gethash nterm (gethash '&prods prod-db)))
                        (get-bodys (gethash nterm (gethash '&prods prod-db))))))))

(defun compile-prod (prod body lexer-fun prod-db)
  (let ((res nil)
        (dollar-args nil))
    (setf dollar-args
          (loop
           with i = 0
           for sym in prod do
           (setf i (+ 1 i))
           collect (intern (concatenate 'string "$" (format nil "~A" i)))))
    (setf dollar-args (append dollar-args (list 'out-val)))
    (setf res
          (loop
           with i = 1
           for sym in prod do
           (if (non-termsym-p sym prod-db)
               (progn
                 (push (list 'multiple-value-setq (list 'insym 'insym-val 'out-val)
                             (compile-prod-sym sym lexer-fun (= i 1) prod-db)) res)
                 (push (list 'setq  (nth (- i 1) dollar-args) 'out-val) res))
             (if (not (empty-term-p sym))
                 (progn
                   (push (list 'setq (nth (- i 1) dollar-args) 'insym-val) res)
                   (push (list 'multiple-value-setq (list 'insym 'insym-val) (list 'funcall lexer-fun)) res))
               (progn
                 nil)))
           (setf i (+ i 1))
           finally
           return res))
    (append (list
             'let
             (mapcar #'(lambda (x) (list x nil)) dollar-args))
            (append (reverse res) (list (list 'values 'insym 'insym-val (cons 'progn body))))))) 
                                                                  
(defun compile-prod-sym (sym lexer-fun is-first prod-db)
  (let ((lex-fun-call (if is-first
                          (list 'values 'insym 'insym-val 'insym-val)
                        (list 'funcall lexer-fun))))
    (cond ((symbolp sym)
           (cond ((empty-term-p sym)
                  (list 'values 'insym 'insym-val nil))
                 ((non-termsym-p sym prod-db)
                  (list sym 'insym 'insym-val lexer-fun))
                 (t lex-fun-call)))
          ((stringp sym)
           lex-fun-call)
          ((listp sym)
           lex-fun-call)
          (t nil))))



(defun show-hash (ht g)
  (maphash #'(lambda (x y) (format t "~A * ~A~%" x (funcall g y))) ht))

(defun show-db (prod-db)
  (show-hash prod-db #'(lambda (x) 
                         (cond ((listp x) x)
                               ((hash-table-p x)(show-hash x #'(lambda (y) (show-db y))))
                               (t x)))))
 

(defmacro defgrammar (&rest args)
  (let ((grammar-name nil)
        (prod-db nil))
    (setf grammar-name (extract-grammar-name args))
    (setf prod-db (build-prod-db args))
    (show-db prod-db)
    (compute-first-and-follow prod-db)
    (format t "Prods ok = ~A ~%" (check-prods prod-db))
    (show-db prod-db)
    (setf res (build-parser prod-db))
;    (list 'quote `(defun ,grammar-name ()
;       ,res))))
    (pprint res)
    `(defun ,grammar-name (lexer)
       ,res)))



(setq tst1 (defgrammar bdf-file
                       
                       (defrule S (LEAD CHARLIS endfont-sym) (list $1 $2))

                       (defrule CHARLIS (CHAR CHARLISR) (cons $1 $2))

                       (defrule CHARLISR (CHAR) (list $1))

                       (defrule CHARLISR (eps) nil)

                       (defrule CHAR (CHARSTARTLINE CHARINFOS CHARENDLINE) $2)

                       (defrule CHARSTARTLINE (startchar-sym CHARNAME) $2)

                       (defrule CHARENDLINE (endchar-sym) nil)

                       (defrule CHARINFOS (ENCODEINFO SWIDTHINFO DWIDTHINFO BBXINFO BITMAPINFO) (list $1 $4 $5))

                       (defrule ENCODEINFO (encoding-sym NUMBER) $2)

                       (defrule SWIDTHINFO (swidth-sym NUMBER NUMBER) (list $2 $3))

                       (defrule DWIDTHINFO (dwidth-sym NUMBER NUMBER) (list $2 $3))

                       (defrule BBXINFO (bbx-sym NUMBER NUMBER NUMBER NUMBER) (list $2 $3 $4 $5))

                       (defrule BITMAPINFO (bitmap-sym BITMAPLIST) $2)

                       (defrule BITMAPLIST (STRNG BITMAPLIST) (cons $1 $2))

                       (defrule BITMAPLIST (eps) nil)


                       (defrule LEAD (startfont-sym STRNG LEADLINES) $3)

                       (defrule LEADLINES (NALINE LEADLINES) nil)

                       (defrule LEADLINES (fbb-sym NUMBER NUMBER NUMBER NUMBER) (list 'FBB $2 $3 $4 $5))))

                       





 







(setq tst 
      
      (defgrammar arith
                  
                  (defrule S (TRM ER ";") (append (list $1) $2))
            
                  (defrule ER (eps) nil)
            
                  (defrule ER ((choose "+-") TRM ER) (append (list $1) (list $2) $3))
            
                  (defrule TRM (NUMBER TRMR) (append (list $1) $2))

                  (defrule TRMR (eps) nil)
                  (defrule TRMR ((choose "*/") NUMBER TRMR) (append (list $1) (list $2) $3))
                  
                  (defrule NUMBER (PRESIGN  MAINNUMBER) (if (null $1) $2
                                                          (list $1 $2)))
                  (defrule PRESIGN ((choose "+-")) $1)
                  (defrule PRESIGN (eps) nil)

                  (defrule MAINNUMBER (INTNUM MAINNUMBERR) (list $1 $2))

                  (defrule MAINNUMBERR ("." INTNUM) (cons $1 $2))
                  (defrule MAINNUMBERR (eps) nil)

                  (defrule INTNUM (DIGIT INTNUMR) (append (list $1) $2))
                  (defrule INTNUMR (DIGIT INTNUMR) (append (list $1) $2))
                  (defrule INTNUMR (eps) nil)

                  (defrule DIGIT ((choose "0123456789")) $1)))






(defun split-string (str delims)
  (let ((spos 0)
        (spos-new 0)
        (len (length str))
        (res nil))
    (loop
      do      
      (setf spos (position-if #'(lambda (c) (not (member c delims))) str :start spos))
      (when (null spos)
        (return-from split-string res))
      (setf spos-new (position-if #'(lambda (c) (member c delims)) str :start spos))
      (when (null spos-new)
        (return-from split-string (reverse (push (subseq str spos len) res))))
      (push (subseq str spos spos-new) res)
      (setf spos spos-new))))



(defun lexbdf ()
  (let ((akt-str (loop 
                  with ch = (funcall rr)
                  with res-str = "" 
                  while (not (or (null (car ch)) (eq (car ch) #\Newline))) do
                  (setf res-str (concatenate 'string res-str (string (car ch))))
                  (setf ch (funcall rr))
                  until (null (car ch))
                  finally return res-str)))
    (split-string akt-str '(#\Space #\Tab))))




(defun check-bbxes ()
  (loop with akt-line = (lexbdf)
    with max-x = 0
    with max-y = 0
    with min-x = 0
    with min-y = 0
    do
    (when (string= (car akt-line) "BBX")
      (print akt-line)
      (let ((x-offs (read-from-string (nth 3 akt-line)))
            (y-offs (read-from-string (nth 4 akt-line)))
            (x-width (read-from-string (nth 1 akt-line)))
            (y-width (read-from-string (nth 2 akt-line))))
        (setf max-x (max max-x (+ x-offs x-width)))
        (setf max-y (max max-y (+ y-offs y-width)))
        (setf min-x (min min-x (+ x-offs 0)))
        (setf min-y (min min-y (+ y-offs 0)))))
    (setf akt-line (lexbdf))
    until (= (length akt-line) 0)
    finally return (list min-x min-y max-x max-y)))
    

(defun rfs (str)
  (read-from-string str))


(defun process-bdf ()
  (let ((glyph-arr (make-array 256)))
    (loop 
     with akt-line = (lexbdf)

     with akt-encoding = nil

     with fbb-x-width = nil
     with fbb-y-width = nil

     with fbb-x-disp = nil
     with fbb-y-disp = nil

     with x-width = nil
     with y-width = nil
     with x-offs = nil
     with y-offs = nil
     do
     (cond ((string= (car akt-line) "FONTBOUNDINGBOX")
            (setf fbb-x-width (rfs (nth 1 akt-line)))
            (setf fbb-y-width (rfs (nth 2 akt-line)))
            (setf fbb-x-disp (rfs (nth 3 akt-line)))
            (setf fbb-y-disp (rfs (nth 4 akt-line)))
            )
           ((string= (car akt-line) "BBX")
            (setf x-width (rfs (nth 1 akt-line)))
            (setf y-width (rfs (nth 2 akt-line)))
            (setf x-offs (rfs (nth 3 akt-line)))
            (setf y-offs (rfs (nth 4 akt-line)))
            )
           ((string= (car akt-line) "ENCODING")
            (setf akt-encoding (rfs (nth 1 akt-line))))
           ((string= (car akt-line) "BITMAP")
            (process-bitmap glyph-arr akt-encoding x-width y-width x-offs y-offs 
                            fbb-x-width fbb-y-width fbb-x-disp fbb-y-disp)))
     (setf akt-line (lexbdf))
     until (= (length akt-line) 0)
     finally return glyph-arr)))
           
    
(defun process-bitmap (glyph-arr glyph-enc xw yw xo yo 
                                 fbb-xw fbb-yw fbb-xdsp fbb-ydsp)
  (let ((akt-glyph (make-array (- fbb-yw fbb-ydsp) :initial-element 0)))
    (loop
     with val = nil
     with akt-line = (lexbdf)
     with y-akt = (+ yw (- yo fbb-ydsp) -1)
     do
     (setf val (ash (parse-integer (car akt-line) :radix 16) (- (+ (- 8 fbb-xw fbb-xdsp) (- xo fbb-xdsp)))))
     (setf (aref akt-glyph y-akt) val)
     (decf y-akt)
     (setf akt-line (lexbdf))
     until (string= (car akt-line) "ENDCHAR")
     finally
     (setf (aref glyph-arr glyph-enc) akt-glyph))))


(defun show-glyph (glyph-arr gl-enc dx dy)
  (let ((out-ch  nil))
   (do ((i (- dy 1) (- i 1)))
       ((< i 0))
     (do ((j (- dx 1) (- j 1)))
         ((< j 0))
       (if (= 0 (logand (aref (aref glyph-arr gl-enc) i) (expt 2 j)))
           (setf out-ch ".")
         (setf out-ch "*"))
       (format t "~a" out-ch))
     (format t "~%"))))


(setf xxx (process-bdf))

(defparameter *ffheight* 11)
(defparameter *ffwidth* 5)

(defun sgl (a b)
  (loop for i from a to b do (show-glyph xxx i *ffwidth* *ffheight*) (format t "~%~%")))



(defun byte-at-pos (glyph-arr line pos)
  (let ((aktpos (+ (* 32 line) pos)))
    (multiple-value-bind (glyph-pos row) (floor aktpos *ffheight*)
      (aref (aref glyph-arr glyph-pos) (- (- *ffheight* 1) row)))))


(defun out-line (glyph-arr line)
  (loop
   with base = 1
   with res = 0
   for pos from 0 to 31 do
   (setf res (+ res (* base (byte-at-pos glyph-arr line pos))))
   (setf base (* base 256))
   finally return res))


(defun make-inits (glyph-arr)
  (with-open-file (f "/home/juergen/ISEProjekte/ProFont-5x11.v" :direction :output)
    (loop
     for line from 0 to 63 do
     (format f "defparam font.INIT_~2,'0X = 256'b~2,256,'0R~%" line (out-line glyph-arr line)))))