#!MUNGERPATH

; Copyright (c) 2004, James Bailie <jimmy@mammothcheese.ca>.
; All rights reserved.
; 
; Redistribution and use in source form, with or without
; modification, are permitted provided that the following conditions are met:
; 
;     * Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;     * The name of James Bailie may not be used to endorse or promote 
; products derived from this software without specific prior written permission.
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

; This program is a file viewer demonstrating the character-I/O functions of
; Munger.  It behaves similarly to vi when that program is invoked as "view".
; Munger must have been built to include the character-I/O interface in order
; for the character-I/O interface to be available.

; Almost all of the vi cursor-motion and buffer-scrolling commands are
; implemented, as well as bookmark operations and regular-expression searches.
; Not all work exactly as they do in vi, although.  Some have been simplified
; for programmer convenience.  Space and tab characters may be specified in
; regular expressions with the \b and \t escape sequences, respectively.

; Five ex commands are recognized:  "e" to load files into the buffer, "n" to
; load the next file specified on the command line, "p" to load the previous
; file specified on the command line, "r" to rewind the argument pointer and
; reload the first file specified on the command line, and "q" to quit the
; viewer.  Filename completion may be requested on the ex command line by
; pressing the tab key.  There are separate editable histories for ex commands
; and for regular-expression searches, which may be browsed with Ctrl-n and
; Ctrl-p. 

; Filenames starting with whitespace must be have a path prepended to them, in
; order for the filename to be understood by the "e" command.  For example if
; one was attempting to view a file whose filename began with whitespace from
; the current directory, one would prepend "./" to the filename.

; Unlike vi, newlines are displayed as spaces at the ends of lines on screen.
; Lines longer than the terminal width are not wrapped and the portions off the
; edge of the screen may be viewed by simply attempting to move the cursor past
; the edge of the screen.  The buffer will scroll horizontally as much as
; necessary to perform the cursor-motion.  The viewer will also resize itself
; upon receipt of SIGWINCH.

(fatal)
(block)
(nocanon)
(open)

(setq tabstop 8)
(setq base 0)
(setq goal 0)

(setq num_lines (lines))
(setq num_cols (cols))
(setq status_line (- num_lines 1))

(setq y 1)
(setq x 0)
(setq r 0)
(setq c 0)

(setq marks (table))

(setq history ())
(setq search_history ())

(setq last_search 0)
(setq search_dir 1)

(setq last_line_search 0)
(setq line_search_dir 1)

(setq repeat 1)
(setq explicit 0)

(setq leading_whitespace_rx (regcomp "^[\b\t]+"))
(setq trailing_whitespace_rx (regcomp "[\b\t]+$"))
(setq whitespace_rx (regcomp "^[\b\t]*$"))

(setq werase_rx (regcomp "/*[^\b\t/]*[\b\t]*$"))
(setq complete_rx (regcomp "^[\b\t]*([^\b\t]+[\b\t]+)?(.*)$"))
(setq mark_rx (regcomp "[a-z]"))

(setq sent_rx (regcomp "[.?!][\"']?(\b\b|$)"))
(setq para_rx (regcomp "^([\b\t]*|\\..*)$"))
(setq func_rx (regcomp "^(\\(|\\{|\\.S)"))
(setq basename_rx (regcomp "^/?([^/]+/)*([^/]+)"))

(setq message
   (lambda (msg bel)
      (clearline status_line 0)
      (print msg)
      (flush_stdout)
      (when bel (beep))
      (goto r c)))

(setq get_char
   (lambda ()

      (let ((c (getchar)))

         (if (not (eq c -2))
            (cond ((eq c -1) 4)
                  ((eq c 13) 10)
                  (1 c))

            (setq num_lines (lines))
            (setq status_line (- num_lines 1))
            (setq num_cols (cols))
            (setq x 0)
            (setq c 0)
            (setq base 0)
            (setq goal 0)
            (redisplay 0)
            (get_char)))))

(let ((zero (code "0"))
      (nine (code "9")))

   (setq get_command
      (lambda ()
         (let ((ch (get_char))
               (num ""))
   
            (setq explicit 0)
            (setq repeat 1)
   
            (if (and (eq num "") (eq ch zero))
               ch
   
               (while (and (>= ch zero) (<= ch nine))
                  (setq explicit 1)
                  (setq num (join "" num (char ch)))
                  (message num 0)
                  (setq ch (get_char)))
   
               (setq repeat (or (digitize num) 1))
               ch)))))

(setq reposition
   (lambda (ignored)

      (let ((key (if (stringp ignored) (digitize ignored) (get_char))))

         (cond  ((eq key 10)
                 (setq r 0))

                 ((eq key 45)
                  (if (< y status_line)
                    (setq r (- y 1))
                    (setq r (- num_lines 2))))

                 ((eq key 46)
                  (if (< y (/ num_lines 2))
                    (setq r (- y 1))
                    (setq r (- (/ num_lines 2) 1))))

                  (1 (beep))))

      (display (- y r) base tabstop)
      (goto r c)))

(setq redisplay
   (lambda (ignored)
      (clearline status_line 0)
      (display (if (lastline) (- y r) 0) base tabstop)
      (goto r c)))

(setq show_coordinates
   (lambda (ignored)
      (clearline status_line 0)

      (let ((last (lastline)))
         (if (not last)
            (progn
               (print "BUFFER IS EMPTY")
               (flush_stdout)
               (beep))

            (print (substitute basename_rx "\2" filename)
               ": " y "." (+ base c) "/" last " "
               "(" (/ (* y 100) last) "%) ")
            (flush_stdout)))

      (goto r c)))

(setq high
   (lambda (offset)

      (letn ((last (lastline)) 
             (top (- y r)) 
             (gap (- last top)) 
             (offset (- offset 1)))

         (if (or (> offset gap) (> offset status_line))
            (beep)
            (setq y (+ top offset))
            (setq r offset)
            (start_of_text 1)))))

(setq middle
   (lambda (ignored)

      (letn ((last (lastline)) 
             (top (- y r)) 
             (half (/ status_line 2)))

         (if (< (- last top) status_line) 
            (progn
               (setq r (/ (- last top) 2))
               (setq y (+ r top)))

            (setq y (- (+ top half) 1))
            (setq r (- half 1)))

         (start_of_text 1))))

(setq low
   (lambda (offset)

      (letn ((last (lastline)) 
             (winlines (- num_lines 2))
             (top (- y r)) 
             (gap (- last top)))

         (if (> (dec offset) gap)
            (beep)

            (if (< gap winlines)
               (progn
                  (setq y (- last offset))
                  (setq r (- y top)))

               (setq r (- winlines offset))
               (setq y (+ top r)))))

      (start_of_text 1)))

(setq start_of_text
   (lambda (ignored)
      (when base 
         (setq base 0)
         (clearline status_line 0)
         (display (- y r) base tabstop))

      (setq x 0)
      (setq c 0)
      (setq goal 0)

      (let ((l (chomp (retrieve y))))

         (when (and (match leading_whitespace_rx l)
                    (not (match whitespace_rx l)))
            (forw_word 1)))

      (setq goal (+ base c))
      (seek_goal)))

; Moves cursor to first character of text, if any, on preceding buffer line.

(setq back_start_of_text
   (lambda (repeat)
      (hide)
      (back_line repeat)
      (start_of_text 0)
      (show)))

; Moves cursor to first character of text, if any, on succeeding buffer
; line.

(setq forw_start_of_text
   (lambda (repeat)
      (hide)
      (forw_line repeat)
      (start_of_text 0)
      (show)))

(setq forw_scroll
   (lambda (repeat)

      (letn ((top (- y r))
             (old top)
             (last (lastline)))

         (when (not (eq top last))
            (setq goal (+ base c))

            (catch
               (while repeat
                  (if (eq top last) (throw 1))

                  (inc top)
                  (dec r)

                  (when (< r 0)
                     (setq r 0)
                     (inc y))

                  (dec repeat)))

            (if (> (- top old) 1)
               (display top base tabstop)

               (clearline status_line 0)
               (scrollup)
               (goto (- status_line 1) 0)
               (setq old (+ (- y r) (- status_line 1)))
               (if (> old last)
                  (print "~")
                  (print (chomp (slice old base num_cols tabstop 0)))
                  (flush_stdout)))

            (seek_goal)))))

(setq back_scroll
   (lambda (repeat)

      (letn ((top (- y r)) 
             (old (- y r))
             (gap (- status_line 1)))

         (when (not (eq top 1))
            (setq goal (+ base c))

            (catch
               (while repeat
                  (if (eq top 1) (throw 1))

                  (dec top)
                  (inc r)

                  (when (>= r status_line)
                     (setq r (- status_line 1))
                     (dec y))

                  (dec repeat)))

            (if (> (- old top) 1)
               (display top base tabstop)

               (scrolldn)
               (goto 0 0)
               (print (chomp (slice top base num_cols tabstop 0)))
               (flush_stdout))

            (clearline status_line 0)
            (seek_goal)))))

(setq compensate
   (lambda ()

      (let ((len (- num_cols 1)))

         (cond ((< c base)
                (setq base c)
                (setq c 0)
                (display (- y r) base tabstop))

                ((> (- c base) len)
                 (setq base (- c len))
                 (setq c len)
                 (display (- y r) base tabstop))

                (base (setq c (- c base)))))

      (goto r c)))

(setq seek_goal
   (lambda ()
      (letn ((off (and x (cadr (slice y 0 x tabstop 1))))
             (len (car (slice y 0 0 tabstop 1)))
             (last (and len (- len 1))))

         (when (> x last) (setq x last))

         (while (and (< x last) (< (+ x off) goal))
            (inc x)
            (setq off (cadr (slice y 0 x tabstop 1))))

         (while (and x (> (+ x off) goal))
            (dec x)
            (setq off (cadr (slice y 0 x tabstop 1))))

         (setq c (+ x off))
         (compensate))))

(setq add_offset
   (lambda ()
      (let ((off (and x (cadr (slice y 0 x tabstop 1)))))
         (setq c (+ x off)))))

(setq start_of_line
   (lambda (ignored)
      (when (lastline)
         (when base 
            (setq base 0)
            (clearline status_line 0)
            (display (- y r) base tabstop))

         (setq x 0)
         (setq c 0)
         (setq goal 0)
         (goto r c))))

(setq end_of_line
   (lambda (ignored)
      (when (lastline)
         (setq x (- (car (slice y 0 0 1 1)) 1))
         (add_offset)
         (compensate)
         (setq goal (+ base c)))))

(setq search
   (lambda (repeat dir)

      (letn ((old history)
             (pat "")
             (tmp "")
             (rx ""))

         (setq history search_history)
         (when (setq tmp (get_string (if (> dir 0) "/" "?") "" 0 1))
            (setq pat tmp))
         (setq search_history history)
         (setq history old)

         (if (stringp (setq rx (regcomp (or tmp ""))))
            (message rx 1)

            (setq last_search rx)
            (find_pattern repeat dir rx 0)))))

(setq forw_search
   (lambda (repeat)
      (search repeat (setq search_dir 1))))

(setq back_search
   (lambda (repeat)
      (search repeat (setq search_dir -1))))

(setq search_again
   (lambda (repeat dir)
      (if (not last_search)
         (message "NO STORED PATTERN" 1)
         (find_pattern repeat dir last_search 0))))

(setq forw_search_again
   (lambda (repeat)
      (search_again repeat search_dir)))

(setq  back_search_again
   (lambda (repeat)
      (search_again repeat (if (> search_dir 0) -1 1))))

(setq find_pattern
   (lambda (n d rx l)

      (let ((f ())
            (oy y)
            (ox x)
            (ny y)
            (nx x))

         (catch
            (while n
               (set 'f (find d ny nx rx (and (not l) 1)))

               (if (not (car f))
                  (progn
                     (if l
                        (if (> d 0)
                           (progn
                              (hide)
                              (goto_line (lastline))
                              (end_of_line 1)
                              (show))

                           (goto_location 1 0))

                        (message "NOT FOUND" 1))

                     (throw 0))

                  (setq ny (car f))
                  (setq nx (cadr f))
                  (setq n (- n 1))))

            (goto_location ny nx)

            (when (or (and (> d 0) (or (< ny oy) (and (eq ny oy) (<= nx ox))))
                      (and (< d 0) (or (> ny oy) (and (eq ny oy) (>= nx ox)))))
               (message "SEARCH WRAPPED" 1))

            1))))

(setq goto_line
   (lambda (line)
      (if explicit
         (goto_location line 0)
         (end_of_buffer 1))))

(setq goto_location
   (lambda (line col)

      (if (or (<= line 0) (> line (lastline)))

         (message "LINE OUT OF RANGE" 1)

         (letn ((top (- y r))
                (gap (- line top))
                (half (/ status_line 2)))

            (setq y line)

            (if (and (>= gap 0) (< gap status_line))
               (setq r (- y top))
               (setq r (if (<= y half) (- y 1) half))
               (display (- y r) base tabstop))

            (let ((len (length (chomp (slice line 0 0 tabstop 0)))))
               (if (> col len)
                  (message "COLUMN OUT OF RANGE" 1)

                  (setq x col)
                  (add_offset)
                  (compensate)
                  (setq goal (+ base c))
                  1))))))

(setq end_of_buffer
   (lambda (ignored)
      (hide)
      (goto_location (lastline) 0)
      (show)))

(setq forw_line
   (lambda (repeat)

      (let ((last (lastline))
            (bottom (- num_lines 2))
            (flag 0))

         (while (and repeat (< y last))
            (inc y)
            (if (< r bottom)
               (inc r)
               (inc flag ))
            (dec repeat))

         (when flag 
            (if (> flag 1)
               (display (- y r) base tabstop)

               (scrollup) 
               (goto bottom 0) 
               (print (chomp (slice y base num_cols tabstop 0)))
               (flush_stdout)))

         (clearline status_line 0)
         (seek_goal))))

(setq back_line
   (lambda (repeat)

      (let ((flag 0))

         (while (and repeat (> y 1))
            (dec y)
            (if (> r 0)
               (dec r)
               (inc flag))
            (dec repeat))

         (when flag 
            (if (> flag 1)
               (display (- y r) base tabstop)

               (scrolldn) 
               (clearline status_line 0)
               (goto 0 0) 
               (print (chomp (slice y base num_cols tabstop 0)))
               (flush_stdout)))

         (clearline status_line 0)
         (seek_goal))))

(setq forw_to_char
   (lambda (repeat)
      (setq line_search_dir 1)
      (forw_till repeat 0)))

(setq back_to_char
   (lambda (repeat)
      (setq line_search_dir 0)
      (back_till repeat 0)))

(setq forw_again
   (lambda (repeat)
      (when last_line_search
         (if line_search_dir
            (forw_till repeat last_line_search)
            (back_till repeat last_line_search)))))

(setq back_again
   (lambda (repeat)
      (when last_line_search
         (if line_search_dir
            (back_till repeat last_line_search)
            (forw_till repeat last_line_search)))))

(setq forw_till
   (lambda (repeat ch)

      (when (lastline)
   
         (let ((idx 1)
               (line (chomp (substring (retrieve y) x 0))))
   
            (if (< (length line) 2)
               (message "NO CHARACTERS AFTER CURSOR" 1)
   
               (when (not ch)
                  (setq ch (char (get_char)))
                  (setq last_line_search ch))
   
               (catch
                  (setq line (cdr (split "" line)))
   
                  (while repeat
                     (catch
                        (while line
                           (when (eq ch (car line))
                              (forw_char idx)
                              (throw 0))
   
                           (inc idx)
                           (setq line (cdr line))))
   
                     (when (not line)
                        (throw (message "NOT FOUND" 1)))
   
                     (setq idx 1)
                     (setq line (cdr line))
                     (dec repeat))))))))
   
(setq back_till
   (lambda (repeat ch)

      (when (lastline)
   
         (let ((idx 1)
               (line (if x (substring (retrieve y) 0 x) "")))
   
            (if (eq line "")
               (message "NO CHARACTERS BEFORE CURSOR" 1)
   
               (when (not ch)
                  (setq ch (char (get_char)))
                  (setq last_line_search ch))
   
               (catch
                  (setq line (reverse (split "" line)))
   
                  (while repeat
                     (catch
                        (while line
                           (when (eq ch (car line))
                              (back_char idx)
                              (throw 0))
   
                           (inc idx)
                           (setq line (cdr line))))
   
                     (when (not line)
                        (throw (message "NOT FOUND" 1)))
   
                     (setq line (cdr line))
                     (setq idx 1)
                     (dec repeat))))))))
   
(setq forw_char
   (lambda (repeat)

      (letn ((len (car (slice y 0 0 1 1)))
             (end (and len (- len 1)))
             (last (lastline)))

         (while repeat

            (if (eq x end)
               (if (eq y last)
                  (set 'repeat 1)
                  (forw_line 1)
                  (start_of_line 1))

               (inc x))

            (dec repeat)))

      (add_offset)
      (compensate)
      (setq goal (+ base c))))

(setq back_char
   (lambda (repeat)

      (let ((last (lastline)))

         (while repeat

            (if (eq x 0)
               (if (eq y 1)
                  (setq repeat 1)
                  (back_line 1)
                  (end_of_line 1))

               (dec x))

            (dec repeat)))


      (add_offset)
      (compensate)
      (setq goal (+ base c))))

(setq is_word
   (lambda (c)
      (setq c (code c))
      (or (and (<= c 57) (>= c 48))
          (and (<= c 90) (>= c 65))
          (and (<= c 122) (>= c 97)))))

(setq is_special
   (lambda (c)
      (setq c (code c))
      (or (and (<= c 47) (>= c 33))
          (and (<= c 64) (>= c 58))
          (and (<= c 96) (>= c 91))
          (and (<= c 126) (>= c 123)))))

(setq is_space
   (lambda (c)
      (and (not (is_word c)) (not (is_special c)))))

(setq find_word_forw
   (lambda ()

      (let ((chars (split "" (slice y x 0 1 0)))
            (goal "")
            (other 0))

         (if (not chars)
            0

            (cond  ((is_word (car chars))
                    (setq goal is_word)
                    (setq other is_space))

                    ((is_special (car chars))
                     (setq goal is_special)
                     (setq other is_space))

                    (1 (setq goal is_space)))

            (while (and chars (goal (car chars)))
               (setq x (+ x 1))
               (setq chars (cdr chars)))

            (while (and other chars (other (car chars)))
               (setq x (+ x 1))
               (setq chars (cdr chars)))

            (if chars
               1
               (setq x (- (car (slice y 0 0 tabstop 1)) 1))
               0)))))

(setq forw_word
   (lambda (repeat)
      (hide)

      (let ((last (lastline))
            (tmp ""))

         (while repeat

            (if (find_word_forw)
               (dec repeat)

               (if (eq y last)
                  (set 'repeat 0)

                  (forw_line 1)
                  (setq x 0)
                  (setq tmp (code (retrieve y)))
                  (when (and (not (eq tmp 32))  ; space
                             (not (eq tmp 9))   ; tab
                             (not (eq tmp 13))  ; carriage-return
                             (not (eq tmp 10))) ; newline
                     (dec repeat))))))

      (add_offset)
      (compensate)
      (show)
      (setq goal (+ base c))))

(setq find_word_back
   (lambda ()

      (if (not x)
         0

         (let ((chars (reverse (split "" (slice y 0 x 1 0))))
               (goal "")
               (other 0))

            (if (not chars)
               0

               (cond  ((is_word (car chars))
                       (setq goal is_word))

                      ((is_special (car chars))
                       (setq goal is_special))

                      (1 
                        (setq goal is_space)
                        (setq other 1)))

               (while (and chars (goal (car chars)))
                  (setq x (- x 1))
                  (set 'chars (cdr chars)))

               (if (not other)
                  1

                  (if (not chars)
                     0

                     (cond  ((is_word (car chars))
                             (setq goal is_word))

                            ((is_special (car chars))
                             (setq goal is_special)))

                     (while (and chars (goal (car chars)))
                        (setq x (- x 1))
                        (set 'chars (cdr chars)))

                     1)))))))

(setq back_word
   (lambda (repeat)
      (hide)

      (while repeat
         (if (find_word_back)
            (dec repeat)

            (if (eq y 1)
               (setq repeat 0)

               (back_line 1)
               (setq x (car (slice y 0 0 1 1))))))

      (add_offset)
      (compensate)
      (show)
      (setq goal (+ base c))))

(setq forw_sent
   (lambda (repeat)
      (find_pattern repeat 1 sent_rx 1)
      (setq goal (+ base c))))

(setq back_sent
   (lambda (repeat)
      (find_pattern repeat -1 sent_rx 1)
      (setq goal (+ base c))))

(setq forw_para
   (lambda (repeat)
      (find_pattern repeat 1 para_rx 1)
      (setq goal (+ base c))))

(setq back_para
   (lambda (repeat)
      (find_pattern repeat -1 para_rx 1)
      (setq goal (+ base c))))

(setq forw_func
   (lambda (repeat)
      (find_pattern repeat 1 func_rx 1)
      (setq goal (+ base c))))

(setq back_func
   (lambda (repeat)
      (find_pattern repeat -1 func_rx 1)
      (setq goal (+ base c))))

(setq forw_screen
   (lambda (repeat)
      (forw_lines repeat (- num_lines 2))))

(setq forw_half
   (lambda (repeat)
      (forw_lines repeat (- (/ num_lines 2) 1))))

(setq forw_lines
   (lambda (repeat add)
      (high 1)

      (let ((last (lastline))
            (screen num_lines))

         (while (and repeat (< y last))
            (setq r 0)

            (if (> (+ y add) last)
               (progn
                  (setq y last)
                  (when (< last screen)
                     (setq r (- last 1))))

               (setq y (+ y add)))

            (dec repeat)))

      (setq base 0)
      (setq c 0)
      (setq x 0)

      (display (- y r) base tabstop)
      (clearline status_line 0)
      (goto r c)))

(setq back_screen
   (lambda (repeat)
      (back_lines repeat (- num_lines 2))))

(setq back_half
   (lambda (repeat)
      (back_lines repeat (- (/ num_lines 2) 1))))

(setq back_lines
   (lambda (repeat sub)
      (high 1)

      (while (and repeat (> y 1))
         (setq r 0)
         (setq y (if (< (- y sub) 1) 1 (- y sub)))
         (dec repeat))

      (setq base 0)
      (setq c 0)
      (setq x 0)

      (display (- y r) base tabstop)
      (clearline status_line 0)
      (goto r c)))

(setq forw_history
   (lambda (str)

      (let ((back ())
            (forw ())
            (new ""))

         (when history 
            (setq back (car history))
            (setq forw (cadr history)))

         (if (not forw)
            str

            (unless (or (match whitespace_rx str)
                        (and back (eq (car back) str)))
               (setq back (cons str back)))

            (setq new (car forw))
            (setq forw (cdr forw))
            (setq history (list back forw))

            new))))

(setq back_history
   (lambda (str)

      (let ((back ())
            (forw ())
            (new ""))

         (when history
            (setq back (car history))
            (setq forw (cadr history)))

         (if (not back)
            str

            (unless (and forw (eq (car forw) str))
               (setq forw (cons str forw)))

            (setq new (car back))
            (setq back (cdr back))
            (setq history (list back forw))

            new))))

(setq consolidate_history
   (lambda (c lh str)

      (let ((back ())
            (forw ()))

         (when history
            (setq back (remove str (remove lh (remove "" (car history)))))
            (setq forw (remove str (remove lh (remove "" (cadr history))))))

         (setq forw (reverse forw))

         (when (and (not (eq lh "")) (not (eq lh str)))
           (setq forw (append forw (list lh))))

         (when (not (eq c 3))
            (setq forw (cons str forw)))

         (setq history (list (append forw back) ())))

      str))

(setq complete_string
   (lambda (str)
      (let ((c (complete str))
            (str "")
            (top "--")
            (len 0))

         (setq str (car c))
         (setq c (cdr c))

         (if (not c)
            str

            (display (if (lastline) (- y r) 0) base tabstop)

            (setq len (length c))

            (if (< len status_line)
               (inc len)
               (setq len status_line)
               (setq top "- list truncated -"))

            (clearline (- status_line len) 0)
            (print top)
            (flush_stdout)
            (dec len)

            (while len
               (clearline (- status_line len) 0)
               (print (car c))
               (flush_stdout)
               (dec len)
               (setq c (cdr c)))

            str))))

(setq get_string
   (lambda (prompt str compl hist)
      (let ((len (length prompt))
            (len2 0)
            (line "")
            (lh "")
            (mess 0)
            (m ())
            (c ""))

         (setq str (expand tabstop str))
         (setq len2 (length str))

         (setq line (join "" prompt 
            (if (< (+ len len2) num_cols)
               str
               (substring str (- len2 (- (- num_cols len) 1)) 0))))

         (setq len2 (length line))
         (clearline status_line 0)
         (print line)
         (flush_stdout)
         (goto status_line len2)

         (catch
            (while (and (not (eq (setq c (get_char)) 10)) (not (eq c 13)))

               (cond ((eq c 3) (throw 0))
                     ((eq c 8) (setq str (chop str)))

                     ((and compl (eq c 9)) 
                      (when (setq m (matches complete_rx str))
                         (setq str 
                           (join "" (cadr m) (complete_string (car (cddr m)))))
                         (setq mess 1)))

                     ((and hist (eq c 14))
                      (setq str (forw_history lh))
                      (setq lh str))

                     ((and hist (eq c 16))
                      (setq str (back_history lh))
                      (setq lh str))

                     ((eq c 21) (setq str ""))
                     ((eq c 22) (setq str (join "" str (char (get_char)))))
                     ((eq c 23) (setq str (substitute werase_rx "" str)))
                     ((eq c -2) (throw 0))

                     ((and (>= c 32) (<= c 126)) 
                      (setq str (join "" str (char c))))

                     (1 (beep)))

               (setq str (expand tabstop str))
               (setq len2 (length str))

               (setq line (join "" prompt 
                  (if (< (+ len len2) num_cols)
                     str
                     (substring str (- len2 (- (- num_cols len) 1)) 0))))

               (setq len2 (length line))
               (clearline status_line 0)
               (print line)
               (flush_stdout)
               (goto status_line len2)))

         (when mess (display (if (lastline) (- y r) 0) base tabstop))
         (goto r c)

         (when hist 
            (consolidate_history c lh str))

         (if (not (eq c 3))
            str
            (message "CANCELLED" 1)
            0))))

(setq load_file
   (lambda (file)
      (if (match whitespace_rx file)
         (message "FILENAME NEEDED" 1)

         (setq file (substitute leading_whitespace_rx "" file))

         (if (not (exists file))
            (message "NO SUCH FILE" 1)

            (empty)
            (setq filename file)

            (let ((lns (read 0 filename)))
               (if (< lns 0)
                  (message "PERMISSION DENIED" 1)

                  (foreach (lambda (x) (unhash marks x)) (keys marks))

                  (setq y 1)
                  (setq x 0)
                  (setq r 0)
                  (setq c 0)

                  (setq goal 0)
                  (setq base 0)

                  (display (if (lastline) 1 0) 0 tabstop)
                  (message (stringify lns " LINES READ") 0)))))))

(setq ex_command
   (lambda (ignored)

      (let ((cmd (get_string ":" "" 1 1)))

         (when (stringp cmd)
            (setq cmd 
               (substitute leading_whitespace_rx ""
                  (substitute trailing_whitespace_rx "" cmd)))

            (if (match whitespace_rx cmd)
               (message "" 0)

               (cond ((eq cmd "q") 
                      (goto status_line 0)
                      (newline)
                      (canon)
                      (quit))

                     ((eq cmd "n")
                      (if (next)
                        (load_file (current))
                        (message "NO MORE ARGUMENTS" 1)))

                     ((eq cmd "p")
                      (prev)
                      (if (eq (current) proggy)
                         (progn
                            (next)
                            (message "NO ARGUMENTS" 1))

                         (if (eq (current) script)
                            (progn
                               (next)
                               (message "AT FIRST ARGUMENT" 1))

                            (load_file (current)))))

                     ((eq cmd "r")
                      (rewind)
                      (next)
                      (if (next)
                        (load_file (current))
                        (message "NO FILENAME ARGUMENTS")))

                     ((eq (substring cmd 0 1) "e")
                      (load_file 
                        (if (> (length cmd) 1)
                           (substring cmd 1 0)
                           "")))

                     (1 (message "UNRECOGNIZED" 1))))))))
 
(setq set_mark
   (lambda (ignored)
      (let ((mark (get_char)))
         (if (not (match mark_rx (char mark)))
            (message "BOOKMARKS MUST BE ONE OF [a-z]" 1)
            (setmark mark y)
            (hash marks mark x)))))

(setq goto_mark
   (lambda (ignored)

      (let ((mark (get_char)))
         (if (not (match mark_rx (char mark)))
            (message "BOOKMARKS MUST BE ONE OF [a-z]" 1)

            (setq mark (getmark mark))

            (if (eq mark 0)
                (message "MARK HAS NOT BEEN SET" 1)
                (setq explicit 1)
                (goto_line mark))))))

(setq goto_precise_mark
   (lambda (ignored)

      (let ((mark (get_char))
            (line 1))

         (if (not (match mark_rx (char mark)))
            (message "BOOKMARKS MUST BE ONE OF [a-z]" 1)

            (setq line (getmark mark))

            (if (eq line 0)
                (message "MARK HAS NOT BEEN SET" 1)
                (goto_location line (lookup marks mark)))))))

(setq command_alist
    (qquote
      ((,(code "z") reposition)
      (12  redisplay)             ; C-l
      (7   show_coordinates)      ; C-G

      (,(code ":") ex_command)

      (,(code "H") high)
      (,(code "M") middle)
      (,(code "L") low) 

      (,(code "^") start_of_text) 
      (,(code "+") forw_start_of_text)
      (,(code "-") back_start_of_text)

      (5 forw_scroll)             ; C-e
      (25 back_scroll)            ; C-y

      (,(code "m") set_mark)
      (,(code "'") goto_mark)
      (,(code "`") goto_precise_mark)

      (,(code "/") forw_search)
      (,(code "?") back_search)

      (,(code "n") forw_search_again)
      (,(code "N") back_search_again)

      (,(code "f") forw_to_char)
      (,(code "F") back_to_char)

      (,(code ";") forw_again) 
      (,(code ",") back_again)

      (,(code "G") goto_line)

      (,(code "l") forw_char)
      (,(code "h") back_char)

      (,(code "w") forw_word)
      (,(code "b") back_word)

      (,(code "0") start_of_line)
      (,(code "$") end_of_line)

      (,(code "j") forw_line)
      (,(code "k") back_line)

      (,(code "(") back_sent)
      (,(code ")") forw_sent)

      (,(code "{") back_para)
      (,(code "}") forw_para)

      (,(code "]") forw_func)
      (,(code "[") back_func)

      (4  forw_half)              ; C-d
      (21 back_half)              ; C-u

      (6  forw_screen)            ; C-f
      (2  back_screen))))         ; C-b

(setq commands (table))
(mapcar (lambda (cmd) (hash commands (car cmd) (cadr cmd))) command_alist)

(display 0 0 tabstop)
(clearline status_line 0)
(print "File Viewer")
(flush_stdout)
(goto r c)

(setq proggy (current))
(next)
(setq script (current))

(when (next)
   (load_file (current)))

(setq process_commands
   (lambda ()

      (letn ((cmd ""))

         (loop
            (if (setq cmd (lookup commands (get_command)))

               (if (or (lastline) (eq cmd 'ex_command))
                  ((eval cmd) repeat)
                  (message "BUFFER IS EMPTY" 1))

               (message "NOT UNDERSTOOD" 1))))))

(process_commands)
