; .EnTete "Le-Lisp (c) version 15.2" " " "L'e'diteur de ligne"
; .EnPied " " "%" " "
; .Chapitre 16 "L'e'diteur de ligne"
;
; .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: edlin.ll,v 4.1 88/01/13 12:19:28 kuczynsk Rel $"

(unless (>= (version) 15.21)
        (error 'load 'erricf 'edlin))

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

(add-feature 'edlin)


; .Section "Gestion d'un historique des commandes"

(setq #:sys-package:colon '#:edlin:history)

(defvar :last-string)
(defvar :maxlen 100)
; l'history commence toujours par une chaine vide
; comme ca, il n'y a plus de flag :at-end
(defvar :history '("" "; In principium erat Le_Lisp..."))
(defvar :position :history)

(de  :show ()
     (terpri 2)
     (:show-aux (cdr :history)))

(de  :show-aux (history)
     ; on ne conse pas : on alloue dynamiquement de la pile
     (if (null history) 0
         (let ((no-line (:show-aux (cdr history))))
              (print (incr no-line) "        " (car history))
              no-line)))

(de  :previous ()
     (if (cdr :position)
         (setq :position (cdr :position))
         (tybeep))
     (car :position))

(de  :next ()
    (if (:endp) (tybeep)
        (let ((history :history))
             (until (eq (cdr history) :position)
                    (nextl history))
             (setq :position history)))
    (car :position))

(de  :add (str)
     (let ((history :history))
          (repeat (sub :maxlen 2) (nextl history))
          (setq :history
                (rplac (if (null (cdr history))
                           ; un nouveau cons
                           (ncons ())
                           ; on reprend le dernier cons
                           (prog1 (cdr history) (rplacd history nil))) 
                       ; on remet la tete d'history (chaine vide)
                       (car :history)
                       ; et la chaine a conserver
                       (rplaca :history str)))))

(de  :find (s)
     (let ((position :position))
          (tag found
               (while (cdr :position)
                      (:previous)
                      (when (index s (car :position))
                            (exit found (car :position))))
               (tybeep)
               (setq :position position)
               () )))

(de  :last ()
     (car (setq :position :history)))

(de  :first ()
     (car (setq :position (last :history))))

(de  :endp ()
     (eq :position :history))


; .Section "Utilitaires"

(setq #:sys-package:colon '#:edlin:util)

(defvar :tampon (makestring 256 #\sp))

(de  :insert-in-string (string pos max cn)
     (if (eq pos max)
         (sset string pos cn)
         (bltstring :tampon 0 string pos (sub max pos))
         (sset string pos cn)
         (bltstring string (add1 pos) :tampon 0 (sub max pos))))

(de  :delete-in-string (string pos max)
     (if (eq pos max)
         (sset string pos (sref string (add1 pos)))
         (bltstring :tampon 0 string (add1 pos) (sub1 (sub max pos)))
         (bltstring string pos :tampon 0 (sub1 (sub max pos)))))


; .Section "Gestion de l'image du tampon d'entre'e"

(setq #:sys-package:colon 'edlin)

(de  :image:redisplay ()
     (tycr) (tycleol) (tyflush)
     (tystring (prompt) (slength (prompt)))
     (:image:redisplay-eol 0))

(de  :image:redisplay-eol (pos)
     (let ((:pos pos))
          (:image:tycleol)
          (:image:move :max))
     (:image:tycleol)
     (setq pos :pos)
     (let ((:pos :max))
          (:image:move pos)))

(de  :image:move (x)
     (cond ((lt :pos x)
            (let ((pos :pos))
                 (until (eq pos x)
                        (tyctl tycn (sref :inbuf pos)) 
                        (setq pos (add1 pos)))))
           ((gt :pos x)
            (let ((pos :pos))
                 (until (eq pos x)
                        (tyctl tybs (sref :inbuf 
                                           (setq pos (sub1 pos)))))))))

(de  :image:insert (cn)
     (if (eq :pos :max)
         (tyctl tycn cn)
         ; on aide les terminaux vt100
         (unless (tyctl tyinsch cn)
                 (:image:redisplay-eol (sub1 :pos)))))

(de  :image:delete (cn)
     (unless (tyctl tydelcn cn)
             (:image:redisplay-eol :pos)))

(de  :image:delete-without-redisplay (cn)
     (tyctl tydelcn cn))

(de  :image:tycleol ()
     (unless (tycleol)
             ; ca marche a peu pres
             ; dans la mesure ou on traite les caracteres un par un
             (tycn #\sp) (tybs #\sp))
     (tyflush))

(dmd tyctl (tyfnt x)
     `(let ((x ,x))
           (when (lt x #\sp)
                 (,tyfnt #/^)
                 (setq x (logor x #$40)))
           (,tyfnt x)))


; .Section "Edition de ligne a` la Emacs"

(setq #:sys-package:colon 'edlin)

(defvar :inbuf)
; le kill-buffer est global et conserve entre 2 appels a :bol
(defvar :kill-buffer (copy (inbuf)))    ; copie pour wipe & yank
(defvar :kill-length 0)                 ; longueur du yank
(defvar :max)
(defvar :pos)
; pour attendre la parenthese ouvrante (voir insert-rpar)
(defvar :loop 1000)

(de  :bol ()
     (if (or (fixp (inchan))
             (not #:system:real-terminal-flag)
             #:system:line-mode-flag)
         (super-itsoft '#.#:sys-package:colon 'bol ())
         (let ((:inbuf (inbuf))        ; le tampon de lecture
               (:last-string ())
               (:pos 0)        ; la position courante
               (:max 0))
              (tystring (prompt) (slength (prompt)))
              (unless (:history:endp)
                      (:do-command #^N))
              (untilexit eoi        ; jusqu'a` la fin de l'input
                      (:work-on (tyi)))
              (tynewline)
              (inmax :max)
              (inpos 0))))

(de  :work-on (char)
     (if (and (eq :pos 0) (eq :max 0)
              (or (eq (typecn char) 'cmacro) (eq (typecn char) 'smacro)))
         (:insert char)
         (or (:do-command char) (:insert char))))

(de  :insert (char)
     (:util:insert-in-string :inbuf :pos :max char)
     (setq :pos (add1 :pos))
     (setq :max (add1 :max))
     (:image:insert char)
     (when (ge :max (slength :inbuf))
           (exit eoi)))

(de  :delete (char)
     (:util:delete-in-string :inbuf :pos :max)
     (setq :max (sub1 :max))
     (:image:delete char))

(de  :delete-without-redisplay (char)
     (:util:delete-in-string :inbuf :pos :max)
     (setq :max (sub1 :max))
     (:image:delete-without-redisplay char))

(de  :move (x)
     (:image:move x)
     (setq :pos x))

(de  :do-command (char)
     (block :do-command
         (selectq char
               (#^A (:move 0))
               (#^E (:move :max))
               (#^B (when (gt :pos 0)
                          (:move (sub1 :pos))))
               (#^F (when (lt :pos :max)
                          (:move (add1 :pos))))
               ((#\cr #\lf)
                    (exit eoi (:store-line) (:history:last)))
               (#^O (exit eoi (:store-line)))
               ((#^H 127)
                (when (gt :pos 0)
                      (:move (sub1 :pos))
                      (:delete (sref :inbuf :pos))))
               (#^D (when (lt :pos :max)
                          (:delete (sref :inbuf :pos))))
               (#^K (setq :last-string ())
                    (:delete-end-of-line))
               ((#^X #^U) (setq :last-string ())
                          (:delete-begining-of-line))
               (#^Y (:insert-substring :kill-buffer :kill-length))
               (#^I (:replace-string (:history:previous)))
               (#^N (:replace-string (:history:next)))
               (#^T
                (when (gt :pos 1)
                      (let ((char1 (sref :inbuf (sub :pos 2)))
                            (char2 (sref :inbuf (sub :pos 1))))
                           (:move (sub :pos 2))
                           (:delete char1) (:delete char2)
                           (:insert char2) (:insert char1))))
               (#^L (:redisplay))
               (#/\ (:insert (tyi)))
               (#\esc (:do-esc-command (tyi)))
               (#|(|# #/) (:insert-rpar))
               (t (return-from :do-command ())))
           t ))

(de  :do-esc-command (char)
     (block :do-esc-command
            (selectq char
               (#"0123456789"
                (let ((count (sub char #/0)))
                     (while (memq (setq char (tyi)) '#"0123456789")
                            (setq count (add (sub char #/0) (mul count 10))))
                     (repeat count (:work-on char))))
               (#/?
                (terpri)
                (with ((inchan (openi (catenate #:system:llib-directory
                                          "edhelp"
                                          #:system:lelisp-extension))))
                      (untilexit eof (print (readstring))))
                (terpri)
                (:redisplay))
               (#/b (:backword #^B))
               (#/f (:forword #^F))
               ((#^H #\del) (:backword #^H))
               (#/h (:history:show)
                    (:redisplay))
               ((#/d #^D) (:forword #^D))
               (#^G (tybeep))
               (#/< (:replace-string (:history:first)))
               (#/> (:replace-string (:history:last)))
               (#\esc
                (let ((s (:history:find
                             ; :last-string est remis a () dans bol et ^U
                             (or :last-string
                                 (setq :last-string
                                       (substring :inbuf 0 :max))))))
                     (when s (:replace-string s))))
               (#\sp (:find-in-oblist :pos))
               (#/' (let ((pos :pos))
                         (:backword #^B)
                         (:insert #/')
                         (repeat (sub (add1 pos) :pos) (:do-command #^F))))
               (#/( #|)|# (:move (:backwardparen :pos)))
               (t (tybeep) (return-from :do-esc-command ())))
           t ))

(de  :find-in-oblist (pos)
     (:backword #^B)
     (let ((l (sub pos :pos))
           (s (:search-in-oblist :pos
                  (substring :inbuf :pos (sub pos :pos)))))
          (repeat l (:do-command #^F))
          (cond ((atom s) (tybeep))
                ((null (cdr s))
                 (setq s (string (car s)))
                 (for (i l 1 (sub1 (slength s)))
                      (:insert (sref s i))))
                (t (terpri)
                   (mapc 'print (setq s (sort 'alphalessp s)))
                   (terpri)
                   (setq s (:comm-string s))
                   (:redisplay)
                   (for (i l 1 (sub1 (slength s)))
                        (:insert (sref s i)))))))

(de  :store-line ()
     (when (gt :max 0)
           ; allocation et stockage d'une nouvelle string
           (:history:add (substring :inbuf 0 :max)))
     (sset :inbuf :max #\cr) (setq :max (add1 :max))
     (sset :inbuf :max #\lf) (setq :max (add1 :max)))

(de  :delete-end-of-line ()
     (bltstring :kill-buffer 0 :inbuf :pos (sub :max :pos))
     (setq :kill-length (sub :max :pos))
     (repeat (sub :max :pos)
	     (when (lt :pos :max)
		   (:delete-without-redisplay (sref :inbuf :pos))))
     (:image:redisplay-eol :pos))

(de  :delete-begining-of-line ()
     (bltstring :kill-buffer 0 :inbuf 0 :pos)
     (setq :kill-length :pos)
     (repeat :pos (when (gt :pos 0)
			(:move (sub1 :pos))
			(:delete-without-redisplay (sref :inbuf :pos))))
     (:image:redisplay-eol :pos))

(de  :insert-substring (s l)
     (for (i 0 1 (sub1 (imin l (slength s))))
          (:insert (sref s i))))

(de  :replace-string (s)
     (let ((l (slength s)))
          (bltstring :inbuf 0 s 0 l)
          (setq :max l  :pos :max))
     (:redisplay))

(de  :alphap (char)
     (eq (typecn char) 'cpname))

(de  :backword (com)
     (until (or (eq :pos 0) (:alphap (sref :inbuf (sub1 :pos))))
            (:do-command com))
     (while (and (gt :pos 0) (:alphap (sref :inbuf (sub1 :pos))))
            (:do-command com)))

(de  :forword (com)
     (until (or (eq :pos :max) (:alphap (sref :inbuf :pos)))
            (:do-command com))
     (while (and (lt :pos :max) (:alphap (sref :inbuf :pos)))
            (:do-command com)))

(de  :redisplay ()
     (:image:redisplay))

(de :search-in-oblist (pos string)
    (let (pkgc (npos pos))
         (while (and (gt npos 0)
                     (or (memq (chrnth (sub1 npos) :inbuf) '#":#")
                         (:alphap (chrnth (sub1 npos) :inbuf))))
                (setq npos (sub1 npos)))
         (setq pkgc
               (car (catcherror ()
                        (implode (explode (substring :inbuf
                                             npos (sub (sub1 pos) npos)))))))
         (maploblist
             (lambda (u)
                     (when (and (eq pkgc (packagecell u))
                                (eq 0 (index string (string u) 0)))
                           (ncons u))))))

(de :comm-string (lsymb)
    ; lsymb est trie'e par ordre alphabetique
    (let ((s1 (string (car lsymb)))
          (s2 (string (car (last lsymb)))))
         (let ((i 0) (fin (imin (slength s1) (slength s2))))
              (while (and (lt i fin) (eq (sref s1 i) (sref s2 i)))
                     (setq i (add1 i)))
              (substring s1 0 i))))

(de :insert-rpar ()
    (:insert #|(|# #/))
    (:move (prog1 :pos (:move (:backwardparen :pos)) (tyflush)
                       (repeat :loop (setq :pos :pos)))))


(de :backwardparen (pos)
    (let ((depth 1))
         (when (gt pos 0)
               (decr pos 1)
               (while (and (gt pos 0)
                           (or (neq 'clpar (typecn (sref :inbuf pos)))
                               (gt (decr depth 1) 0)))
                      (decr pos)
                      (or (neq 'crpar (typecn (sref :inbuf pos)))
                          (setq depth (add1 depth))))))
    pos )


; .Section "Les Fonctions Utilisateur"

(de  edlin ()
     (unless (memq '#.#:sys-package:colon #:sys-package:itsoft)
             (setq #:sys-package:itsoft
                   (cons '#.#:sys-package:colon #:sys-package:itsoft))))

(de  edlinend ()
     (setq #:sys-package:itsoft
           (delq '#.#:sys-package:colon #:sys-package:itsoft)))