;;;-*- Mode:lisp; Package:ZWEI; Base:10; Fonts:(cptfont) -*-

;;; GATEWAY-INDEX-MAKER. THIS PROGRAM SEMI-AUTOMATES CONVERSION OF THE
;;; STAND-ALONE CHINEUAL INDEX TO THE GATEWAY CHINEUAL INDEX.

;********************************************************************************

; DECLARATIONS OF GLOBAL VARIABLES.

(defconst *INDEX-STREAM* nil)			;STREAM FOR READING INDEX ENTRIES
(defconst *NODE-STREAM* nil)			;STREAM FOR READING NODE NAMES
(defconst *OUTPUT-STREAM* nil)			;STREAM FOR WRITING NODULATED INDEX ENTRIES

(defconst *OLD-INDEX-PAGE* nil)			;PAGE OF THE PREVIOUS INDEX ENTRY

(defconst *CURRENT-INDEX-ENTRY* nil)		;COMPLETE TEXT OF THE CURRENT INDEX ENTRY
(defconst *CURRENT-INDEX-OUTPUT-TEXT* nil)	;OUTPUT TEXT OF THE CURRENT INDEX ENTRY
(defconst *CURRENT-INDEX-DISPLAY-TEXT* nil)	;DISPLAY TEXT OF THE CURRENT INDEX ENTRY
(defconst *CURRENT-INDEX-PAGE* nil)		;PAGE OF THE CURRENT INDEX ENTRY
(defconst *CURRENT-INDEX-TRAILER* nil)		;TRAILER OF THE CURRENT INDEX ENTRY
(defconst *CURRENT-INDEX-ENTRY-ITEM* nil)	;TV:MENU ITEM MADE FROM THE CURRENT INDEX ENTRY

(defconst *CURRENT-NODE-NAME* nil)		;COMPLETE TEXT OF THE CURRENT NODE NAME
(defconst *CURRENT-NODE-OUTPUT-TEXT* nil)	;OUTPUT TEXT OF THE CURRENT NODE NAME
(defconst *CURRENT-NODE-DISPLAY-TEXT* nil)	;DISPLAY TEXT OF THE CURRENT NODE NAME
(defconst *CURRENT-NODE-PAGE* nil)		;PAGE OF THE CURRENT NODE NAME 
(defconst *NODE-NAMES-ITEM-LIST* nil)		;TV:MENU ITEM-LIST OF ALL NODE NAMES FOR THE CURRENT INDEX ENTRY

(defconst *QUIT-FLAG* nil)			;FLAG CONTROLLING OFFERING OF QUIT COMMAND

(defconst *SELECTED-VALUE* nil)			;VALUE SELECTED FROM A SELECTION OPERATION BY THE USER

;********************************************************************************

(defun INITIALIZE-GLOBAL-VERYABLES () 
  
  (when *index-stream*
    (close *index-stream*)
    (setq *index-stream* nil)
    )
  (when *node-stream*
    (close *node-stream*)
    (setq *node-stream* nil)
    )
  (when *output-stream*
    (close *output-stream*)
    (setq *output-stream* nil)
    )

  (setq
    *old-index-page* "000"

    *current-index-entry* ""
    *current-index-output-text* ""
    *current-index-display-text* ""
    *current-index-page* "000"
    *current-index-trailer* ""
    *current-index-entry-item* (list nil)
    
    *current-node-name* ""
    *current-node-output-text* ""
    *current-node-display-text* ""
    *current-node-page* "000"
    
    *node-names-item-list* (list nil)

    *quit-flag* nil

    *selected-value* ""
    )
  
  )

;********************************************************************************

(defun MGI (&optional (page "000"))

  (initialize-global-veryables)
  (open-streams)
  (initialize-streams page)
  (make-gateway-index)
  (close-streams)
  t
  )

;********************************************************************************

(defun OPEN-STREAMS () 

  (setq *index-stream* (open "wall:swrs;source-for-odm-index.text#>"))
  (setq *node-stream* (open "wall:swrs;page-nodename-translation-table.text#>"))
  (setq *output-stream* (open "wall:swrs;gateway-index.lisp#>"
			      :direction :output
			      :if-does-not-exist :create
			      :if-exists :append
			      )))

;********************************************************************************

(defun CLOSE-STREAMS () 
  (when *index-stream*
    (close *index-stream*)
    (setq *index-stream* nil)
    )
  (when *node-stream*
    (close *node-stream*)
    (setq *node-stream* nil)
    )
  (when *output-stream*
    (close *output-stream*)
    (setq *output-stream* nil)
    )
  )

;********************************************************************************

(defun initialize-streams (page)

  (tagbody LOOP1
      (get-and-prepare-an-index-entry)
      (unless (string-equal *current-index-page* page)
	(go LOOP1))
      )
  (tagbody LOOP2
      (setq *current-node-name* (read-node-name))
      (setq *current-node-output-text* (get-output-text-of-current-node-name))
      (setq *current-node-display-text* (get-display-text-of-current-node-name))
      (setq *current-node-page* (get-page-of-current-node-name))
      (unless (string-equal *current-node-page* page)
	(go LOOP2))
      )
  (get-and-prepare-node-names)
  )

;********************************************************************************

(defun MAKE-GATEWAY-INDEX () 

  (tagbody LOOP
      (and
        (process-a-selection)
        (get-and-prepare-an-index-entry)
	(get-and-prepare-node-names)
	(go LOOP)
	)))

;********************************************************************************

;;; CENTRAL INDEX-MAKING ROUTINES


(defun GET-AND-PREPARE-AN-INDEX-ENTRY () 
  (and
    (setq *current-index-entry* (read-index-entry))
    (setq *old-index-page* *current-index-page*)
    (setq *current-index-output-text* (get-output-text-of-current-index-entry))
    (setq *current-index-display-text* (get-display-text-of-current-index-entry))
    (setq *current-index-page* (get-page-of-current-index-entry))
    (setq *current-index-trailer* (get-trailer-of-current-index-entry))
    (setq *current-index-entry-item* (make-node-item-from-current-index-entry))
    ))


(defun GET-AND-PREPARE-NODE-NAMES () 
  (cond
    ((equal *old-index-page* *current-index-page*) t)  ;CURRENT LIST OK: DO NOTHING
    ((not (listen *node-stream*)) nil)		       ;EOF: DO NOTHING
    (t 
     (setq *node-names-item-list* (list nil))	       ;OLD LIST OUTDATED. MAKE NEW ONE
     (tagbody LOOP
	 (and
	   (equal *current-node-page* *current-index-page*)
	   (setq *node-names-item-list* (append *node-names-item-list* (make-node-item-from-current-node)))
	   (setq *current-node-name* (read-node-name))
	   (setq *current-node-output-text* (get-output-text-of-current-node-name))
	   (setq *current-node-display-text* (get-display-text-of-current-node-name))
	   (setq *current-node-page* (get-page-of-current-node-name))
	   (go LOOP))
	 )
     (setq *quit-flag* t)
     )))


(defun PROCESS-A-SELECTION (&aux choice-list)
  
  (setq choice-list (append *current-index-entry-item* *node-names-item-list* (space-item))) 
  (cond 
    
    ((equal (length choice-list) 7)
     (write-nodulated-entry (third (fifth choice-list))))
    
    ((and
       *quit-flag*
       (setq *selected-value* (tv:menu-choose (append choice-list (error-command-item) (quit-command-item)))))
     (cond
       ((string-equal (car *selected-value*) "QUIT-COMMAND-SELECTED")
	(execute-quit-command))
       ((string-equal (car *selected-value*) "ERROR-COMMAND-SELECTED")
	(write-error-entry)
	(process-a-selection))
       (t
	(setq *quit-flag* nil)
	(write-nodulated-entry *selected-value* t))
       ))
    
    ((and
       (not *quit-flag*)
       (setq *selected-value* (tv:menu-choose (append choice-list (error-command-item)))))
     (cond
       ((string-equal (car *selected-value*) "ERROR-COMMAND-SELECTED")
	(write-error-entry)
	(process-a-selection))
       (t
	(write-nodulated-entry *selected-value* t))
       ))
    
    (t (process-a-selection))
    ))

;********************************************************************************

(defun EXECUTE-QUIT-COMMAND ()

  (format t "~%~%START NEXT SESSION BY TYPING: ~%~%(mgi /"~A/")~%~%TO A LISP LISTENER PANE.~%" *current-index-page*)
  nil
  )


;********************************************************************************

;;; ROUTINES FOR READING AND WRITING FILES

(defun READ-INDEX-ENTRY ()
  (when (listen *index-stream*)
    (read-line *index-stream*)
    ))

(defun READ-NODE-NAME () 
  (when (listen *node-stream*)
    (read-line *node-stream*)
    ))

(defun WRITE-NODULATED-ENTRY (selected-value &optional (print-p nil) &aux output-entry display-entry)
  (setq output-entry  (string-append *current-index-output-text* "|" (car selected-value)  "|" *current-index-trailer*))
  (setq display-entry (string-append *current-index-display-text* "   >   " (cadr selected-value)))
  (when print-p (print display-entry))
; (when print-p (print output-entry))
  (write-line output-entry *output-stream*)
  t
  )

(defun WRITE-ERROR-ENTRY (&aux (error-line "*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*"))
  (print error-line)
  (write-line error-line *output-stream*)
  t
  )

;********************************************************************************

;;; STRING-HANDLING ROUTINES

(defun GET-PAGE-OF-CURRENT-NODE-NAME ()
  (substring *current-node-name* 0 3)
  )

(defun GET-OUTPUT-TEXT-OF-CURRENT-NODE-NAME ()
  (substring *current-node-name* 4)
  )

(defun GET-DISPLAY-TEXT-OF-CURRENT-NODE-NAME ()
       (substring
	 *current-node-output-text*
	 (1+ (string-search-set ")" *current-node-output-text*))
	 (string-search-set "|" *current-node-output-text*)
	 ))

(defun GET-PAGE-OF-CURRENT-INDEX-ENTRY (&aux after-bar-location)
  (setq after-bar-location (1+ (string-search-set "|" *current-index-entry*)))
  (substring *current-index-entry* after-bar-location (plus 3 after-bar-location))
  )

(defun GET-OUTPUT-TEXT-OF-CURRENT-INDEX-ENTRY (&aux bar-location) 
  (setq bar-location (string-search-set "|" *current-index-entry*))
  (substring *current-index-entry*
	     0
	     bar-location
	     ))

(defun GET-DISPLAY-TEXT-OF-CURRENT-INDEX-ENTRY () 
  (get-output-text-of-current-index-entry)
  )

(defun GET-TRAILER-OF-CURRENT-INDEX-ENTRY (&aux after-bar-location)
  (setq after-bar-location (1+ (string-search-set "|" *current-index-entry*)))
  (substring *current-index-entry* after-bar-location)
  )

;********************************************************************************

;;; ROUTINES TO CREATE MENU ITEMS

(defun MAKE-NODE-ITEM-FROM-CURRENT-INDEX-ENTRY () 
  (list
    (list
      *current-index-page*
       :no-select
      nil
      :font
      'hl12b
      )
    (list
      *current-index-display-text*
       :no-select
      nil
      :font
      'hl12b
      )
    (list
      ""
      :no-select
      nil
      )))


(defun MAKE-NODE-ITEM-FROM-CURRENT-NODE () 
  (list
    (list
      *current-node-display-text*
      :value
      (list *current-node-output-text* *current-node-display-text*)
      :font
      'cptfont
      )))

(defun SPACE-ITEM ()
  (list
    (list 
      ""
      :no-select
      nil)
    (list
      ""
      :no-select
      nil)
    ))

(defun ERROR-COMMAND-ITEM ()
  (list
    (list
      "WRITE AN ERROR MARKER TO THE OUTPUT FILE"
      :value
      (list "ERROR-COMMAND-SELECTED")
      :font
      fonts:cptfontb)
    ))

(defun QUIT-COMMAND-ITEM ()
  (list
    (list
      "QUIT WITHOUT PROCESSING THIS SELECTION"
      :value
      (list "QUIT-COMMAND-SELECTED")
      :font
      fonts:cptfontb)
    ))

;********************************************************************************

;;; ARCHIVES

;(defun GET-PAGE-OF-CURRENT-INDEX-ENTRY () 
;  (substring *current-index-entry*
;	     (- (string-length *current-index-entry*) 6)
;	     (- (string-length *current-index-entry*) 3)
;	     ))