(cl-user::load-system :geta-strings)
(cl-user::load-system :geta-trees)
; (cl-user::load-system :ted)

;;;---------------------------------------------------------------------------
;;; Transcriptions
;;;---------------------------------------------------------------------------

;;;---------------------------------------------------------------------------
;;; modification to make CASE senSiTive
;;;
(defun buffer-replace-all (buffer old-string new-string)
 ; (print old-string)
 ; (print new-string)
  (set-mark buffer 0)
  (let ((l1 (length old-string))
        (last-position (buffer-string-pos buffer old-string))
        (l2 (length new-string))
        )
    (do () ((not last-position))
      (if (string= (buffer-substring buffer last-position (+ last-position l1)) old-string)
        (progn (buffer-delete buffer last-position (+ last-position l1))
               (buffer-insert buffer new-string last-position)
               (setf last-position (buffer-string-pos buffer old-string :start (+ last-position l2)))
               )
        (setf last-position (buffer-string-pos buffer old-string :start (+ last-position 1)))
        )
      )
    ))

;;;---------------------------------------------------------------------------
;;;
(defmethod transcribe-buffer (buffer (form (eql :to-tex)))
  (buffer-replace-all buffer "�" "\\'{e}")
  (buffer-replace-all buffer "�" "\\^{e}")
  (buffer-replace-all buffer "�" "\\`{e}") 
  (buffer-replace-all buffer "�" "\\\"{e}")

  (buffer-replace-all buffer "�" "\\'{E}")
  (buffer-replace-all buffer "�" "\\^{E}")
  (buffer-replace-all buffer "�" "\\`{E}")
  (buffer-replace-all buffer "�" "\\\"{e}")
  
  (buffer-replace-all buffer "�" "\\'{a}")
  (buffer-replace-all buffer "�" "\\`{a}")
  (buffer-replace-all buffer "�" "\\^{a}")
  (buffer-replace-all buffer "�" "\\'{A}")
  (buffer-replace-all buffer "�" "\\`{A}")
  (buffer-replace-all buffer "�" "\\^{A}")
  
  (buffer-replace-all buffer "�" "\\`{u}")
  (buffer-replace-all buffer "�" "\\'{u}")
  (buffer-replace-all buffer "�" "\\^{u}")
  (buffer-replace-all buffer "�" "\\�{u}")
  (buffer-replace-all buffer "�" "\\`{U}")
  (buffer-replace-all buffer "�" "\\'{U}")
  (buffer-replace-all buffer "�" "\\^{U}")
  (buffer-replace-all buffer "�" "\\\"{U}")
  
  (buffer-replace-all buffer "�" "\\^{o}")
  (buffer-replace-all buffer "�" "\\^{O}")
  (buffer-replace-all buffer "�" "\\\"{o}")
  (buffer-replace-all buffer "�" "\\\"{O}")
  
  (buffer-replace-all buffer "�" "\\^{\\i}")
  (buffer-replace-all buffer "�" "\\\"{\\i}")
  (buffer-replace-all buffer "�" "\\\"{\\I}")
  (buffer-replace-all buffer "�" "\\^{\\I}")
  
  (buffer-replace-all buffer "�" "?")
  (buffer-replace-all buffer "�" "?")
  
  (buffer-replace-all buffer "�" "\\c{c}")
  (buffer-replace-all buffer "�" "\\c{C}")
  
  (buffer-replace-all buffer "�" "\\oe")
  (buffer-replace-all buffer "�" "\\OE") 
  
  (buffer-replace-all buffer "�" "\\ae")
  (buffer-replace-all buffer "�" "\\AE")
  
  buffer
  )

;; (transcribe-string (string-upcase "�il1") :to-tex)

;;;---------------------------------------------------------------------------
;;;
(defmethod transcribe-string (s (how (eql :to-tex)))
  (let ((buffer (make-buffer)))
    (buffer-insert buffer s)
    (transcribe-buffer buffer :to-tex)

    ;; returns the contents of the buffer
    (buffer-substring buffer 0 (buffer-size buffer)) 
    ))

;;;---------------------------------------------------------------------------
;;;
(defun last-character (string)
  (subseq string (- (length string) 1)))


;;;---------------------------------------------------------------------------
;;;
(defun buffer-replace-first-substring (buffer old new)
  (let ((size (length old))
        pos
        )
    (setf pos (ccl::find-firstbm-tables-in-buffer (ccl::compute-bm-tables old t) buffer))
    (when pos
      (buffer-delete buffer pos (+ pos size))
      (buffer-insert buffer  new pos))
    ) )

;;;---------------------------------------------------------------------------
;;;
(defun file-replace-first-substring (old new &optional path)
  (setq path (or path (choose-file-dialog)))
  (when path
    (let ((buffer (make-buffer)))
      (buffer-insert-file buffer path)
      (buffer-replace-first-substring buffer old new)
      
      (buffer-write-file buffer path :if-exists :supersede) 
      )))

;;;---------------------------------------------------------------------------
;;;
(defun file-replace-all-substring (old new &optional path)
  (setq path (or path (choose-file-dialog)))
  (when path
    (let ((buffer (make-buffer)))
      (buffer-insert-file buffer path)
      (buffer-replace-all  buffer old new)
      
      (buffer-write-file buffer path :if-exists :supersede) 
      )))

;;;---------------------------------------------------------------------------
;;;
(defun file-multiple-replace-all-substrings (list-old-new &optional path)
  (setq path (or path (choose-file-dialog)))
  (when path
    (let ((buffer (make-buffer))
          old new)
      (buffer-insert-file buffer path)
      (do () ((not list-old-new))
        (setf old (first list-old-new))
        (setf new (second list-old-new))
        (setf list-old-new (cddr list-old-new))
        (buffer-replace-all buffer old new)
        )
      (buffer-write-file buffer path :if-exists :supersede) 
      )))


#|
(format (ed) "~a" (transcribe-string "
Dans ce chapitre, nous pr�sentons les concepts de base n�cessaire � la compr�hension du reste du cours. Les notions de vocabulaire, de mots et de langages sont introduites. Nous illustrons comment tout traitement informatique est pr�c�d� et suivi de phases de d�codage et de codage dont la nature est un traitement sur un (ou plusieurs) langages.
Les op�rations de base sur les langages seront pr�sent�es ainsi que la classe des langages r�guliers. Les manipulations sur les expressions r�guli�res seront illustr�es.

Nous supposons connues les d�finitions de base de la th�orie des ensembles et de celle des nombres.

" :to-tex))

|#

;; (format-tex-tree '(a c (d  1 2 3 ( 8 7 9))))

(defun format-tex-tree (tree)
  (format (ed) "~a" (%format-tex-tree tree))
  )

(defun %format-tex-tree (tree)
  (when (listp tree)
    (format nil "\\begin{bundle}{~a}~%~a~%\\end{bundle}" 
            (first tree)
            (%format-tex-tree-sons (rest tree))
            )
    ))

(defun %format-tex-tree-sons (tree-list)
  (when tree-list
    (let ((result "")
          )
      (dolist (item tree-list)
        (print item)
        (if (listp item)
          (setf result (format nil "~a\\chunk{~a~%}" result (%format-tex-tree item)))
          (setf result  (format nil "~a\\chunk{~a}~%" result item))
          
          ))
      result
      )))



;;;---------------------------------------------------------------------------
;;; 
;;;
(defun buffer-replace-all (buffer old-string new-string)
 ; (print old-string)
 ; (print new-string)
  (set-mark buffer 0)
  (let ((l1 (length old-string))
        (last-position (buffer-string-pos buffer old-string))
        (l2 (length new-string))
        )
    (do () ((not last-position))
      (if (string= (buffer-substring buffer last-position (+ last-position l1)) old-string)
        (progn (buffer-delete buffer last-position (+ last-position l1))
               (buffer-insert buffer new-string last-position)
               (setf last-position (buffer-string-pos buffer old-string :start (+ last-position l2)))
               )
        (setf last-position (buffer-string-pos buffer old-string :start (+ last-position 1)))
        )
      )
    ))
  
(defun process-tex-file-transcribe (path)
  (let ((b (make-buffer))
        )
    (copy-file path (concatenate 'string (format nil "~a" path) "~") :if-exists :supersede)
    (buffer-insert-file b path)
    (transcribe-buffer b :to-tex)
    (buffer-write-file b path :if-exists :supersede)
    ))


(defun buffer-texcmd-get-args (b cmdname nbargs start)
  (let (pos 
        args begin end
        l token
        rawarg 
        (lastpos start)
        )
    (when (< start (buffer-size b))
      (setf token (concatenate 'string "\\" cmdname "{"))
      (setf l (length token))
      (setf pos (buffer-string-pos b token :start start))
      
      (when pos
        (setf end (- (+ pos l) 1))
        (dotimes (i nbargs)
          (setf begin (buffer-string-pos b "{" :start end))
          (when begin 
            (setf end (buffer-string-pos b "}" :start begin))
            
            (when end
              (setf rawarg (buffer-substring b (+ begin 1) end))
              (setf lastpos end)
              (if (equal (elt rawarg 0) #\()
                (push (read-from-string rawarg) args)
                (push rawarg args))
              
              )
            
            )
          ))
      (when args
        (list lastpos (reverse args))
        ))))


(defun buffer-texenv-get-args (b cmdname nbargs start)
  (let (pos 
        args begin end
        l token
        rawarg 
        (lastpos start)
        )
    (when (< start (buffer-size b))
      (setf token (concatenate 'string "\\begin{" cmdname "}{"))
      (setf l (length token))
      (setf pos (buffer-string-pos b token :start start))
      
      (when pos
        (setf end (- (+ pos l) 1))
        (dotimes (i nbargs)
          (setf begin (buffer-string-pos b "{" :start end))
          (when begin 
            (setf end (buffer-string-pos b "}" :start begin))
            
            (when end
              (setf rawarg (buffer-substring b (+ begin 1) end))
              (setf lastpos end)
              (if (equal (elt rawarg 0) #\()
                (push (read-from-string rawarg) args)
                (push rawarg args))
              
              )
            
            )
          ))
      (when args
        (list lastpos (reverse args))
        ))))

(defun find-autodef (b autoname)
  (let (res 
        (lastpos 0)
        name)
    (do () ((not lastpos))
      (setf res (buffer-texcmd-get-args b "mlautodef" 2 lastpos))
      (setf lastpos (first res))
      (when lastpos
        (setf name (first (second res)))
        (if (string-equal autoname name)
          (return-from find-autodef (second (second res)))
          ))
      )))



(defun process-tex-file-automata (path)
  (let ((b (make-buffer))
        autoname autolayout autodef autographname
        
        (dir (mac-directory-namestring path))
        res 
        (lastpos 0)
        )
    
    (buffer-insert-file b path)
    
    
    (do () ((not lastpos))
      (setf res (buffer-texcmd-get-args b "mlautograph" 3 lastpos))
      (setf lastpos (first res))
      (when lastpos
        (setf autoname (first (second res)))
        
        (setf autographname (second (second res)))
        (setf autolayout (third (second res)))
        (setf autodef (find-autodef b autoname))

        (print autoname)
        
        (when (and autodef autolayout)
          (generer-ps-automaton autodef autolayout dir autographname)
          )
        ))
    
    ))

;; (process-tex-file-automata (choose-file-dialog))


(defun process-tex-file-automata-table (path)
  (let ((b (make-buffer))
        autoname autodef 
        res 
        (lastpos 0)
        string
        endpos
        )
    
    (buffer-insert-file b path)
    
    (do () ((not lastpos))
      (setf res (buffer-texenv-get-args b "mlautotable" 1 lastpos))
      (setf lastpos (first res))
      (when lastpos
        (setf autoname (first (second res)))
        (setf autodef (find-autodef b autoname))
        
        (print autoname)
        (print autodef)
        
        (when autodef
          (setf string (generer-tex-automaton-table autodef))
          (when string 
            (setf endpos (buffer-string-pos b "\\end{mlautotable}" :start lastpos))
            (buffer-delete b (+ lastpos 1) endpos)
            (buffer-insert b string (+ lastpos 1))
            ))
        ))
    
    (buffer-write-file b path :if-exists :supersede)
    
    ))

;; (process-tex-file-automata-table (choose-file-dialog))


(defun process-tex-file-automata-tape (path)
  (let ((b (make-buffer))
        res 
        (lastpos 0)
        string
        endpos
        )
    
    (buffer-insert-file b path)
    
    (do () ((not lastpos))
      (setf res (buffer-texenv-get-args b "mlautotape" 1 lastpos))
      (setf lastpos (first res))
      (when res
        (setf string (generer-tex-automaton-tape (first (second res))))
        
          (when string 
            (setf endpos (buffer-string-pos b "\\end{mlautotape}" :start lastpos))
            (buffer-delete b (+ lastpos 1) endpos)
            (buffer-insert b string (+ lastpos 1))
            )
        ))
    
    (buffer-write-file b path :if-exists :supersede)
    
    ))

;; (process-tex-file-automata-tape (choose-file-dialog))


(defun process-tex-file-tree (path)
  (let ((b (make-buffer))
        (start 0) (end 0)
        s args2 args1
        auto layout
        (token1 "begin{mltree}")
        (token2 "end{mltree}")
        
        (in-string (map 'string #'identity '(#\Linefeed #\return #\newline #\tab)))
        (out-string (map 'string #'identity '(#\space #\space #\space #\space)))
        
        (dir (mac-directory-namestring path))
        )
    
    (buffer-insert-file b path)
    
    (do () ((not start))
      (setf start (buffer-string-pos b token1 :start start))
      (when start (setf end (buffer-string-pos b token2 :start start))
            (when end
              (setf s (buffer-substring b (+ start (length token1)) end))
              
              (setf s (string-trim '(#\space #\tab) s))
              (setf s (geta-strings::translate s  out-string in-string))
              (setf s (string-trim '(#\space #\tab) s))
              (setf s (geta-strings::translate s  
                                               (map 'string #'identity '(#\null #\null))
                                               (map 'string #'identity '(#\{ #\})) 
                                               ) )
              
              (setf args1 (geta-strings::list-words s #\null))
              
              (dolist (arg args1)
                (when (equal (elt arg 0) #\()
                  (setf args2 (append args2 (list arg)))
                  ))
              
              (setf auto (read-from-string (first args2)))
              (setf layout (read-from-string (second args2)))
              
              (print auto)
            ;  (print layout)
              
              (geta-trees::generer-ps-tree auto layout dir)
              
              )
            )
      (setf args2 nil)
      (setf start end)
      (setf end nil)
      )
    ))

(defun fix-newlines (path)
  (let ((b (make-buffer))
        )
    
    (buffer-insert-file b path)
    (buffer-replace-all b (string #\linefeed) (string #\newline))
    (buffer-write-file b path :if-exists :supersede)
    ))


(defun process-tex-file (path)
  (copy-file path (concatenate 'string (format nil "~a" path) "~") :if-exists :supersede)
  (process-tex-file-transcribe path)
  (process-tex-file-automata path)
  (process-tex-file-automata-table path)

  (process-tex-file-automata-tape path)

  (process-tex-file-tree path)


  (fix-newlines path)
  )

;; (process-tex-file-automata (choose-file-dialog))

;; (process-tex-file (choose-file-dialog))


;; (process-tex-file  "Aleph:TAL-antinom:TAL-Antinom.tex")