; .EnTete "Le-Lisp (c) version 15.2" " " "Le compilateur Terminfo"
; .EnPied " " "%" " "
; .SuperTitre "Le Compilateur Terminfo"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
; .Centre "*****************************************************************"

; .Centre "$Header: terminfo.ll,v 4.3 88/04/07 18:26:12 nuyens Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'terminfo))

; Tous les symboles pre'ce'de's de : seront cre'e's
; dans le package TERMINFO.

(defvar #:sys-package:colon 'terminfo)

(add-feature 'terminfo)

; Programme de ge'ne'ration de terminaux virtuels Le_Lisp
; a` partir de la base de donne'es terminfo de UN*X System V.
; Le nom du directory qui contient cette base de donne'e
; doit se trouver dans la variable #:system:terminfo-directory
; ou dans la variable shell TERMINFO.
; le nom du catalogue qui contient les terminaux virtuels
; dans la variable #:system:virtty-directory
; (voir le fichier initial).

; .Section "Lecture de la base de donne'e TERMINFO"

(de :read-entry (term)
    (let ((ti (or (getenv "TERMINFO") #:system:terminfo-directory)))
       (setq ti (string ti))
       (let ((:entry (catenate ti
                               (ifn (eq (sref ti (1- (slength ti))) #//) "/")
                               (ascii (sref term 0))
                               "/"
                               term)))
          (ifn (probefile :entry)
               (error 'terminfo 'ERRVIRTTY term))
          (with ((inchan (openib :entry)))
              (:read-header)
              (:skip :sname)
              (:read-bools)
              (:skip (logand (+ :sname :sbool) 1))
              (:read-numbs)
              (:read-strgs)
              (:read-table)
              (close (inchan))))))

; .Section "Les constantes de TERMINFO"

; Il faut mettre a jour cette table apre`s chaque modification
; de terminfo (4) comme l'ajout d'une capacite'.

(defvar :magic-number #8r432)	; nombre magique de terminfo
(defvar :size-of-boolean-section 21); taille de la section des boole'ens
(defvar :size-of-number-section 8); taille de la section des nombres
(defvar :size-of-string-section 145); taille de la section des chai^nes

; les index des entre'es (avec le nom ANSI)
; en commentaire le nom de la capacite' et l'icode
; (voir terminfo (4))

; les drapeaux

; les nombres

(defvar :columns 0)		; cols co
(defvar :lines 2)		; lines li

; les chai^nes

(defvar :clear_screen 5)	; clear cl
(defvar :clr_eol 6)		; el ce
(defvar :clr_eos 7)		; ed cd
(defvar :cursor_address 10)	; cup cm
(defvar :cursor_invisible 13)	; civis vi
(defvar :cursor_normal 16)	; cnorm ve
(defvar :delete_char 21)	; dch1 dc
(defvar :delete_line 22)	; dl1 dl
(defvar :enter_delete_mode 29)	; smdc dm
(defvar :enter_insert_mode 31)	; smir im
(defvar :enter_standout_mode 35); smso so
(defvar :enter_underline_mode 36); smul us
(defvar :exit_delete_mode 41)	; rmdc ed
(defvar :exit_insert_mode 42)	; rmir ei
(defvar :exit_standout_mode 43)	; rmso se
(defvar :exit_underline_mode 44); rmul ue
(defvar :flash_screen 45)	; flash vb
(defvar :init_1string 48)	; is1 i1
(defvar :init_2string 49)	; is2 i2
(defvar :init_3string 50)	; is3 i3
(defvar :init_file 51)		; if if
(defvar :insert_character 52)	; ich1 ic
(defvar :insert_line 53)	; il1 al
(defvar :init_prog 138)		; iprog iP

; .Section "Les fonctions de lecture"

; lecture d'un nombre sur 16 bits dans l'ordre Vax/Pdp11

(de :read-short ()
    (logor (logand (readcn) 255) (logshift (readcn) 8)))

; saute n octets

(de :skip (n) (repeat n (readcn)))

; lecture de l'en-te^te (voir terminfo (4))

(de :read-header ()
    (ifn (eq (:read-short) :magic-number)
         (error 'terminfo 'erroob :entry))
    (setq :sname (:read-short)
          :sbool (:read-short)
          :snumb (:read-short)
          :sstrg (:read-short)
          :stable (:read-short))
    (ifn (eq :sbool :size-of-boolean-section)
         (:warning 
#- #:system:foreign-language
   "la taille de la zone booleenne ne correspond pas"
#+ #:system:foreign-language
   "the boolean zone doesn't fit"
          ))
    (setq :bools (makevector :sbool ()))
    (ifn (eq :snumb :size-of-number-section)
         (:warning 
#- #:system:foreign-language
   "la taille de la zone des nombres ne correspond pas"
#+ #:system:foreign-language
   "the number zone doesn't fit"
         ))
    (setq :numbs (makevector :snumb ()))
    (ifn (eq :sstrg :size-of-string-section)
         (:warning 
#- #:system:foreign-language
   "la taille de la zone des chaines ne correspond pas"
#+ #:system:foreign-language
   "the string zone doesn't fit"
         ))
    (setq :strgs (makevector :sstrg ()))
    (setq :table (makestring :stable 0)))

; lit les drapeaux (un octet 0 ou 1)

(de :read-bools ()
    (for (i 0 1 (1- :sbool))
       (vset :bools i (eq (readcn) 1))))

; lit les parame`tres nume'riques

(de :read-numbs ()
    (for (i 0 1 (1- :snumb))
       (let ((n (:read-short)))
          (vset :numbs i (if (eq n -1) () n)))))

; lit les param`tres chai^nes (de'placement dans la table)

(de :read-strgs ()
    (for (i 0 1 (1- :sstrg))
       (let ((n (:read-short)))
          (vset :strgs i (if (eq n -1) () n)))))

; lit la table des chai^nes

(de :read-table ()
    (for (i 0 1 (1- :stable))
       (sset :table i (readcn))))

; .Section "Fonctions de ge'ne'ration"

; ge'ne`re le code d'une fonction "cursor"
; a` partir d'une chai^ne terminfo

(de :cursor (l)
    (let ((par1 'line)(par2 'col)(stack)(c)(exp)(special-tyod)(ifl)
          (var (makevector 26 ()))(istack)(ifsl))
       (while l
           (nextl l c)
           (if (neq c #/%)
               (newl exp `(tyo ,c))
               (nextl l c)
               (selectq c
                  (#/% (newl exp `(tyo #/%)))
                  (#/d (newl exp `(tyod ,(nextl stack) 0)))
                  (#/2 (ifn (eq (nextl l) #/d)
                            (error 'terminfo 'errbpa 'cursor))
                       (setq special-tyod t)
                       (newl exp `(:tyod ,(nextl stack) 2)))
                  (#/3 (ifn (eq (nextl l) #/d)
                            (error 'terminfo 'errbpa 'cursor))
                       (setq special-tyod t)
                       (newl exp `(:tyod ,(nextl stack) 3)))
                  (#/0 (nextl l c)
                       (if (and (memq c '(#/2 #/3)) (eq (nextl l) #/d))
                           (newl exp
                                 `(tyod ,(nextl stack) ,(sub c #/0)))
                           (error 'terminfo 'errbpa 'cursor)))
                  ((#/c #/s) (newl exp `(tyo ,(nextl stack))))
                  (#/p (selectq (nextl l)
                          (#/1 (newl stack par1))
                          (#/2 (newl stack par2))
                          (#/3 (newl stack par3))
                          (#/4 (newl stack par4))
                          (#/5 (newl stack par5))
                          (#/6 (newl stack par6))
                          (#/7 (newl stack par7))
                          (#/8 (newl stack par8))
                          (#/9 (newl stack par9))
                          (t (error 'terminfo 'errbpa 'cursor))))
                  (#/P (nextl l c)
                       (ifn (and (>= c #/a) (<= c #/z))
                            (error 'terminfo 'errbpa 'cursor)
                            (vset var (- c #/a) (nextl stack))))
                  (#/g (nextl l c)
                       (ifn (and (>= c #/a) (<= c #/z))
                            (error 'terminfo 'errbpa 'cursor)
                            (newl stack (vref var (- c #/a)))))
                  (#/+ (newl stack `(add ,(nextl stack) ,(nextl stack))))
                  (#/- (newl stack
                             (reverse `(,(nextl stack) ,(nextl stack) sub))))
                  (#/* (newl stack `(mul ,(nextl stack) ,(nextl stack))))
                  (#// (newl stack
                             (reverse `(,(nextl stack) ,(nextl stack) div))))
                  (#/m (newl stack
                             (reverse `(,(nextl stack) ,(nextl stack) rem))))
                  (#/& (newl stack `(logand ,(nextl stack) ,(nextl stack))))
                  (#/| (newl stack `(logor ,(nextl stack) ,(nextl stack))));|
		  ;)
                  (#/= (newl stack `(= ,(nextl stack) ,(nextl stack))))
                  (#/> (newl stack `(< ,(nextl stack) ,(nextl stack))))
                  (#/< (newl stack `(> ,(nextl stack) ,(nextl stack))))
                  (#/! (let ((arg (nextl stack)))
                          (ifn (and (consp arg) (memq (car arg) '(= < >)))
                               (setq arg `(<> 0 ,arg)))
                          (newl stack `(not ,arg))))
                  (#/~ (newl stack `(lognot ,(nextl stack))))
                  (#/i (setq par1 `(add1 ,par1) par2 `(add1 ,par2)))
                  (#/' (newl stack (nextl l))
                       (ifn (eq (nextl l) #/')
                            (error 'terminfo 'errbpa 'cursor)))
                  (#/{ (let (ll c)
                          (until (eq (setq c (nextl l)) #/}) (newl ll c))
                          (newl stack (implode (reverse ll)))))
                  (#/? (newl exp 'if) (setq ifl t))
                  (#/t (newl exp (nextl stack)) (newl exp 'then)
                       (setq istack stack))
                  (#/e (if istack (:save-stack)) (newl exp 'else)
                       (setq stack istack))
                  (#/; (if istack (:save-stack))
                       (newl exp (:cursor-if))
                       (setq ifl () stack ())
                       (when ifsl
                             (for (i 1 1 ifsl)
                                (newl stack
                                      (symbol 'terminfo (catenate "x" i)))))
                       (setq ifsl ()))
                  (t (error 'terminfo 'errbpa 'cursor)))))
       (if (or stack ifl) (error 'terminfo 'errbpa 'cursor))
       (when special-tyod
             (terpri)
             (print "(de #:terminfo:tyod (x n)")
             (print "    (when (or (> n 1) (> x 9))")
             (print "          (#:terminfo:tyod (div x 10) (sub1 n)))")
             (print "    (if (eq x 0) (tyo #\sp)")
             (print "        (tyo (add #/0 (rem x 10)))))"))
       (:de 'tycursor '(col line) exp)))

(de :save-stack ()
    (if (and ifsl (neq ifsl (length stack)))
        (error 'terminfo 'errbpa 'cursor))
    (setq ifsl (length stack) stack (reverse stack))
    (let (ss)
       (for (i 1 1 ifsl)
          (newl ss (nextl stack))
          (newl ss (symbol 'terminfo (catenate "x" i))))
       (newl exp (cons 'setq ss))))

(de :cursor-if ()
    (let (else then test elem)
        (until (memq (setq elem (nextl exp)) '(else then)) (newl else elem))
        (setq else (:compact else))
        (if (eq elem 'then)
            (setq then else else ())
            (until (eq (setq elem (nextl exp)) 'then) (newl then elem))
            (setq then (:compact then)))
        (until (memq (setq elem (nextl exp)) '(if else)) (newl test elem))
        (while test (newl exp (nextl test)))
        (nextl exp test)
        (ifn (and (consp test) (memq (car test) '(= < > not)))
             (setq test `(<> 0 ,test)))
        (ifn (eq elem 'else)
             (:if test then else)
             (newl exp 'else)
             (newl exp (:if test then else))
             (:cursor-if))))

(de :compact (l)
    (if (and (eq (caar l) 'tyo) (eq (caadr l) 'tyo))
        (:compact
            (cons (cons 'tyo (nconc1 (cdar l) (cadadr l))) (cddr l)))
        l))

(de :if (test then else)
    (cond
      ((cdr then)
       (cond
         ((cdr else) `(if ,test ,(newl then 'progn) ,.else))
         ((null else) `(when ,test ,.then))
         (t `(ifn ,test ,@else ,.then))))
      ((null then) `(unless ,test ,.else))
      (t `(if ,test ,@then ,.else))))

    
; Ici, on se livre a` une petite optimisation:
; on concate`ne les tyo conse'cutifs
; et on en profite pour renverser la liste.

(de :de (sem par exp)
    (let (l ltyo)	; l: nouvelle exp; ltyo: liste des char a tyo
       (while exp
              (if (car exp)
                  (selectq (caar exp)
                       (tyo (mapc (lambda (tyo) (newl ltyo tyo))
                                  (reverse (cdr (nextl exp)))))
                       ((incr decr setq) (newl l (nextl exp)))
                       (t
                         (when ltyo
                               (newl l `(tyo ,.ltyo)) (setq ltyo nil))
                         (newl l (nextl exp))))
                  (nextl exp)))
       (when ltyo (newl l `(tyo ,.ltyo)))
       (terpri)
       (with ((lmargin 8))
             (prin "(de #:tty:" (string term) ":" sem " " par)
             (while l
                    (terpri) (outpos 4) (prin (nextl l)))
             (prin ")"))
       (terpri)))

; La me^me mais sans parame`tre et avec n arguments

(de :den (sem . exp) (:de sem () exp))

(de :decaps (sem caps)
    (if (vref :strgs caps)
        (:den sem (:get-string caps))
        (:cant sem)))

(de :cant (sem)
    (terpri)
    (print "; ** terminfo : " term " : ne sais pas faire : " sem)))

(de :set (sem val)
    (terpri)
    (print "(defvar #:tty:" term ":" sem " " val ")")
    (print "(defvar #:tty:" sem " " val ") ;  compatibilite' v15"))

(de :warning (s)
    (terpri)
    (print "Avertissement : terminfo : " s))

; .Section "Les chai^nes de commandes"

(de :get-string (n)
    (setq n (vref :strgs n))
    (if (and (fixp n) (<= 0 n))
        (let (liste)
           (untilexit :eos
              (let ((c (sref :table n)))
                 (incr n)
                 (if (and (eq c #/$) (eq (sref :table n) #/<))
                     (:look-for-delay))
                 (if (eq c 0) (exit :eos))
                 (newl liste c)))
           (cons 'tyo (reverse liste)))))

; saute les de'lais

(de :look-for-delay ()
    (let ((nn n)(cc c))
       (incr n)			; saute <
       (untilexit :eop
           (selectq (sref :table n)
              (#/> (setq n (1+ n) c (sref :table n)) (exit :eop))
              ((#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9 #/* #/.) (incr n))
              (t (setq n nn c cc))))))

; .Section "Fonction Principale"

(de :compile (term output-file)
    (setq term (implode (pname term)))
    (print "; On cree le fichier virtty a partir de terminfo pour : " term)
    (:read-entry (string term))
    (let (#:system:print-for-read)
       ; on regarde si le terminal sait adresser le curseur
       (ifn (vref :strgs :cursor_address)
            (error 'terminfo
#- #:system:foreign-language "Terminal ringard : pas d'adressage curseur"
#+ #:system:foreign-language "Terminal lacks capability : cursor addressing"
                   term))
       ; on regarde si le terminal sait effacer l'ecran
       (ifn (or (vref :strgs :clear_screen) (vref :strgs :clr_eos))
            (error 'terminfo
#- #:system:foreign-language "Terminal ringard : pas d'effacement de l'ecran"
#+ #:system:foreign-language "Terminal lacks capability: clear screen"
                   term))
       ; On commence la generation
       (with ((outchan (openo output-file)))
             ; Une petite banniere
             (print "; Le_Lisp version 15.2 :"
#- #:system:foreign-language
                      " compilation du terminal virtuel : "
#+ #:system:foreign-language
                      " compilation of virtual terminal: "
                    term)
             ; Le nom du systeme
             (terpri)
             (print "(setq #:sys-package:tty '#:tty:" term ")")
             ; Les variables donnant le nombre de lignes et de colonnes
             (when (vref :numbs :columns)
                   (:set 'xmax (1- (vref :numbs :columns))))
             (when (vref :numbs :lines)
                   (:set 'ymax (1- (vref :numbs :lines))))
             ; L'adressage du curseur
             (:cursor (cdr (:get-string :cursor_address)))
             ; S'il existe une visible bell, on rede'finit bell
             (if (vref :strgs :flash_screen) (:decaps 'tybeep :flash_screen))
             ; Effacement de l'e'cran
             (if (vref :strgs :clear_screen)
                 (:decaps 'tycls :clear_screen)
                 (:den 'tycls (:get-string :clr_eos) `(tycursor 0 0)))
             ; Effacement jusqu'a la fin de ligne
             (:decaps 'tycleol :clr_eol)
             ; Effacement jusqu'a la fin de l'ecran
             (:decaps 'tycleos :clr_eos)
             ; Effacement du caractere
             (if (vref :strgs :delete_char)
                 (:den 'tydelch
                       (:get-string :exit_delete_mode)
                       (:get-string :delete_char)
                       (:get-string :enter_delete_mode))
                 (:cant 'tydelch))
             ; Insertion d'une ligne
             (:decaps 'tyinsln :insert_line)
             ; Effacement de la ligne
             (:decaps 'tydelln :delete_line)
             ; L'attribut soulignage ou inverse video
             (when (and (vref :strgs :enter_standout_mode)
                        (vref :strgs :exit_standout_mode))
                   (:de 'tyattrib '(x)
                        (list `(if x
                                   ,(:get-string :enter_standout_mode)
                                   ,(:get-string :exit_standout_mode))))
                   (:set 'tyattrib ()))
             (when (and (vref :strgs :enter_underline_mode)
                        (vref :strgs :exit_underline_mode))
                   (:de 'tyattrib '(x)
                        (list `(if x
                                   ,(:get-string :enter_underline_mode)
                                   ,(:get-string :exit_underline_mode))))
                   (:set 'tyattrib ()))
             ; Pour inserer un caractere ou une chaine
             (if (or (vref :strgs :insert_character)
                     (vref :strgs :enter_insert_mode)
                     (vref :strgs :exit_insert_mode))
                 (:de 'tyinsch '(arg)
                      (list
                          (:get-string :exit_insert_mode)
                          `(tyo arg)
                          (:get-string :insert_character)
                          (:get-string :enter_insert_mode)))
                 (:cant 'tyinsch))
             ; La chaine d'initialisation
             ; La caracteristique if de terminfo
             (let (l)
                (if (vref :strgs :init_file)
                    (with ((inchan
                              (openib
                                  (string (cdr (:get-string :init_file))))))
                        (untilexit eof (newl l (readcn)))))
                (:den 'typrologue
                      `(,(symbol (symbol 'tty term) 'tycls))
                      (:get-string :init_1string)
                      (:get-string :init_2string)
                      `(tyo ,.(reverse l))
                      (if (vref :strgs :init_prog)
                          `(comline
                              ,(string (cdr (:get-string :init_prog)))))
                      (:get-string :init_3string)))
             ; Pour l'epilogue, on ramene simplement le curseur
             (:den 'tyepilogue
                   `(tycursor 0 (1- ,(symbol (symbol 'tty term) 'ymax))))
             ; Le curseur cache'/vu
             (when (and (vref :strgs :cursor_invisible)
                        (vref :strgs :cursor_normal))
                   (:de 'tyshowcursor '(x)
                        (list `(if x
                                   ,(:get-string :cursor_normal)
                                   ,(:get-string :cursor_invisible)))))
             (:set 'tyshowcursor t)
             (close (outchan)))
       term))