;------------------------------------------------------------
; File:  greenclay.l of green of clay of clos of lisp of ai

;------------------------------------------------------------
; Enter clos
;  ( in-package "pcl" )

;------------------------------------------------------------
; required packages
;  ( load "../clay.l" )

;------------------------------------------------------------
; Classes

  ( defclass green-clay
    () 
    ( ( reader :accessor clay-reader :initarg :reader ) 
      ( standard-world :accessor clay-standard-world 
        :initarg :standard-world ) 
      ( current-world :accessor clay-current-world 
        :initarg :current-world ) 
      ( output-stream :accessor clay-output-stream 
        :initarg :output-stream :initform *standard-output*) 
      ( parser-monitor :accessor clay-parser-monitor 
        :initarg :parser-monitor :initform nil ) 
      ( color :accessor clay-color 
        :initarg color :initform 'green ) 
    )
  )

  ( defclass green-clay-command 
    ( ) 
    ( ( name :accessor clay-command-name :initarg :name )
      ( description :accessor clay-command-description
                    :initarg :description :initform ""
      )
    )
  )

  ( defclass full-command-spec
    ( ) 
    ( ( world :accessor full-command-spec-world
              :initarg :world
      )
      ( command 
          :accessor full-command-spec-command
          :initarg :command
      )
    )
  )

  ( defclass green-parser
    (parser)
    ()
  )

  ( defclass green-processor
    (processor)
    ()
  )

  ( defclass green-clay-world
    () 
    ( ( name :accessor world-name 
             :initarg :name 
      ) 
      ( parent :accessor world-parent
             :initarg :parent :initform '()
      ) 

      ( x-commands :accessor world-x-commands 
                 :initarg :x-commands :initform '()
      )
    )
  )

  ( defclass reader
    () 
    ( ( natural-line :accessor reader-natural-line 
                     :initarg :natural-line 
                     :initform ""
      ) 
      ( formal-line :accessor reader-formal-line 
                    :initarg :formal-line 
                    :initform ""
      ) 
      ( expanded-line :accessor reader-expanded-line 
                      :initarg :expanded-line 
                      :initform ""
      ) 
      ( tokenized-line :accessor reader-tokenized-line 
                       :initarg :tokenized-line 
                       :initform ""
      )
      ( input-stream :accessor reader-input-stream 
                       :initarg :input-stream
                       :initform *standard-input*
      ) 
      ( monitor :accessor reader-monitor :initarg :monitor :initform nil ) 
 
    )
  )

  ( defmethod set-reader-input-stream ( ( r reader ) ( filename string ) &aux full-file-name )
    ( setf full-file-name
      ( concatenate 'string 
        "/home/blue/public_html/ai/lisp/clos/clay/" 
        ( string-downcase ( string (clay-color gc) ) )
        "/domains/" ; or "/" if not in a domain FIX IT
        filename
      ) 
     )
     ( setf ( reader-input-stream r ) 
        ( open full-file-name )
     )
  )

  ( defmethod reset-reader-input-stream ( ( r reader ) )
      ( setf ( reader-input-stream r ) *terminal-io* )
  )

  ( defclass green-clay-command-family
    () 
    ( ( name :accessor green-clay-command-family-name 
             :initarg :name 
      ) 
      ( commands :accessor green-clay-command-family-commands 
                 :initarg :commands 
      )
    )
  )


;------------------------------------------------------------
; Clay Reader Functionality

  ( defmethod read-natural-line ( ( gc green-clay ) &aux cr )
    ( setf cr ( clay-reader gc ) )
    ( issue-prompt gc )
    ( setf ( reader-natural-line cr ) ( read-natural-line-helper cr ) )
  )

  ( defmethod read-natural-line-without-prompt ( ( gc green-clay ) &aux cr )
    ( setf cr ( clay-reader gc ) )
    ( setf ( reader-natural-line cr ) ( read-natural-line-helper cr ) )
  )

  ( defmethod read-natural-line-helper ( ( cr reader ) &aux input)
    ( setf input ( read-line  ( reader-input-stream cr ) nil 'eof ) )
    ( if ( eq input 'eof ) ( throw 'terminate-clay NIL ) )
    ( setf input ( strip-trailing-blanks input ) )
    ( if ( not ( last-char-is-period input ) )
      ( setf input ( concatenate 'string input ( read-natural-line-helper cr ) ) )
    )
    input
  )

  ( defmethod display-reader ( ( os t ) ( cr reader ) )
    ( write-line "Natural input line ..." os )
    ( write-line ( reader-natural-line cr ) os )
    ( write-line "Formal input line ..." os )
    ( write-line ( reader-formal-line cr ) os )
    ( write-line "Expanded input line ..." os )
    ( write-line ( reader-expanded-line cr ) os )
    ( write-line "Tokenized input line ..." os )
    ( dolist ( x ( reader-tokenized-line cr ) )
      ( display-token os x )
    )
    ( terpri os )
  )

  ( defmethod read-clay-line ( (gc green-clay) )

    ( read-natural-line gc )
    ( formalize-natural-line gc )
    ( expand-formal-line gc )
    ( tokenize-expanded-line gc )
  )

  ( defmethod read-clay-line-without-prompt ( (gc green-clay) )

    ( read-natural-line-without-prompt gc )
    ( formalize-natural-line gc )
    ( expand-formal-line gc )
    ( tokenize-expanded-line gc )
  )

  ( defmethod formalize-natural-line 
    ( ( gc green-clay ) &aux ns fs starter ender )

    ( setf cr ( clay-reader gc ) )
    ( setf ns ( reader-natural-line cr ) )
    ( cond 
      ( ( looks-like-green-clay-p ns )
        ( setf starter "[ " )
        ( setf ender "" )
      )
      ( ( looks-like-red-clay-p ns )
        ( setf starter "[ [ " )
        ( setf ender " ]" )
      )
      ( ( looks-like-blue-clay-p ns )
        ( setf starter "[ [ " )
        ( setf ender " ] ]" )
      )
    )
    ( setf ( reader-formal-line cr ) 
      ( concatenate 'string ( convert-nf ns starter ) ender )
    )
  )

  ( defmethod looks-like-green-clay-p ( ( ns string ) )
    ( and ( = ( count #\, ns ) 0 ) ( = ( count #\= ns ) 0 ) )
  )

  ( defmethod looks-like-red-clay-p ( ( ns string ) )
    ( and ( > ( count #\, ns ) 0 ) ( = ( count #\= ns ) 0 ) )
  )

  ( defmethod looks-like-blue-clay-p ( ( ns string ) )
    ( and  ( > ( count #\= ns ) 0 ) )
  )


  ( defmethod convert-nf ( ( n string ) ( f string ) )
    ( cond
      ( ( string-equal n "" )
        f
      )
      ( ( char-equal ( elt n 0 ) #\, )
        ( convert-nf 
          ( strip-leading-blanks ( subseq n 1 ) ) 
          ( concatenate 'string f " ] [ " ) 
        )
      )
      ( ( char-equal ( elt n 0 ) #\= )
        ( convert-nf 
          ( strip-leading-blanks ( subseq n 1 ) ) 
          ( concatenate 'string f "] = [ [ " ) 
        )
      )
      ( ( and ( char-equal ( elt n 0 ) #\. ) ( = ( length n ) 1 ) )
        ( convert-nf ( subseq n 1 ) ( concatenate 'string f " ]" ) )
      )
      ( t
        ( convert-nf 
          ( subseq n 1 ) 
          ( concatenate 'string f ( subseq n 0 1 ) ) 
        )
      )
    )
  )      

  ( defmethod expand-formal-line ( ( gc green-clay ) )
    ( setf cr ( clay-reader gc ) )
    ( setf ( reader-expanded-line cr ) ( reader-formal-line cr ) )
  )

  ( defmethod tokenize-expanded-line ( ( gc green-clay ) &aux s result )
    ( setf cr ( clay-reader gc ) )
    ( setf s ( reader-expanded-line cr ) )
    ( setf result ( tokenize gc s ) )
    ( setf ( reader-tokenized-line cr ) result )
  )

  ( defmethod tokenize ( ( gc green-clay ) ( s string ) &aux dc result )
    ( setf result '() )
    ( loop
      ( if ( string-equal s "" ) ( return-from tokenize ( reverse result ) ) )
      ( setf dc ( elt s 0 ) )
      ( cond
        ( ( char-equal dc #\  )
          ( setf s ( subseq s 1 ) )
        )
        ( ( char-equal dc #\[ )
          ( multiple-value-setq
            ( new-token s )
            ( tokenize-from-left-bracket dc ( subseq s 1 ) )
          )
          ( push new-token result )
        )
        ( ( char-equal dc #\] )
          ( multiple-value-setq
            ( new-token s )
            ( tokenize-from-right-bracket dc ( subseq s 1 ) )
          )
          ( push new-token result )
        )
        ( ( char-equal dc #\= )
          ( multiple-value-setq
            ( new-token s )
            ( tokenize-from-equal-sign dc ( subseq s 1 ) )
          )
          ( push new-token result )
        )
        ( ( clay-ref-char-p dc )
          ( multiple-value-setq
            ( new-token s )
            ( tokenize-from-ref-char dc ( subseq s 1 ) )
          )
          ( push new-token result )
        )
        ( ( clay-id-char-p dc )
          ( multiple-value-setq
            ( new-token s )
            ( tokenize-from-id-char dc ( subseq s 1 ) )
          )
          ( push new-token result )
        )
        ( t
          ( clay-error gc "Lexical error." )
          ( throw 'invalid-lexical-input NIL )
        )
      )
    )
  )


  ( defmethod tokenize-from-right-arrow ( ( c character ) ( s string ) )
    ( cond
      ( ( or ( string-equal s "" ) 
             ( char-equal ( elt s 0 ) #\  ) 
        )
        ( values 
          ( make-instance 'token :name ">" :type 'right-arrow )
          s
        )
      )
      ( ( clay-id-char-p c )
        ( tokenize-from-id-char c ( subseq s 1 ) )
      )
    )
  )

  ( defmethod tokenize-from-equal-sign ( ( c character ) ( s string ) )
    ( cond
      ( ( or ( string-equal s "" ) 
             ( char-equal ( elt s 0 ) #\  ) 
        )
        ( values 
          ( make-instance 'token :name "=" :type 'equal-sign )
          s
        )
      )
      ( ( clay-id-char-p c )
        ( tokenize-from-id-char c ( subseq s 1 ) )
      )
    )
  )

  ( defmethod tokenize-from-left-bracket ( ( c character ) ( s string ) )
    ( cond
      ( ( or ( string-equal s "" ) 
             ( char-equal ( elt s 0 ) #\  ) 
        )
        ( values
          ( make-instance 'token :name "[" :type 'left-bracket )
          s
        )
      )
      ( ( clay-id-char-p c )
        ( tokenize-from-id-char c ( subseq s 1 ) )
      )
    )
  )

  ( defmethod tokenize-from-right-bracket ( ( c character ) ( s string ) )
    ( cond
      ( ( or ( string-equal s "" ) 
             ( char-equal ( elt s 0 ) #\  ) 
        )
        ( values
          ( make-instance 'token :name "]" :type 'right-bracket )
          s
        )
      )
      ( ( clay-id-char-p c )
        ( tokenize-from-id-char c ( subseq s 1 ) )
      )
    )
  )

  ( defmethod tokenize-from-id-char ( ( c character ) ( s string ) )
    ( tokenize-id "" c s )
  )

  ( defmethod tokenize-from-ref-char ( ( c character ) ( s string ) )
    ( tokenize-ref "" c s )
  )

  ( defmethod tokenize-id  
    ( ( token-so-far string ) ( c character ) ( s string ) &aux tok )

    ( cond
      ( ( or ( string-equal s "" ) ( char-equal c #\  ) )
        ( if ( absolute-referencer-p token-so-far )
          ( setf tok ( strip-color-prefix token-so-far ) )
          ;( if ( string-equal *domain* "" )
            ( setf tok token-so-far )
         ;   ( setf tok ( concatenate 'string *domain* ">" token-so-far ) )
          ;)
        )
        ( values
          ( make-instance 'token :name tok :type 'id )
          ( concatenate 'string ( list c ) s )
        )
      )
      ( ( clay-id-char-p c )
        ( tokenize-id
          ( concatenate 'string token-so-far ( list c) )
          ( elt s 0 )
          ( subseq s 1 )
        )
      )
      ( t
        ( clay-error *terminal-io* "Lexical error:  \"identifier\" expected." )
        ( throw 'invalid-lexical-input NIL )
      )
    )     
  )

  ( defmethod absolute-referencer-p ( ( s string ) )
    ( or
      ( char= ( elt s 0 ) #\@ )
      ( and ( >= ( length s ) 6 ) ( string-equal ( subseq s 0 6 ) "green>" ) )
      ( and ( >= ( length s ) 4 ) ( string-equal ( subseq s 0 4 ) "red>" ) )
      ( and ( >= ( length s ) 5 ) ( string-equal ( subseq s 0 5 ) "blue>" ) )
    )
  )

  ( defmethod strip-color-prefix ( ( s string ) )
    ( cond
      ( ( char= ( elt s 0 ) #\@ )
        ( subseq s 1 )
      )
      ( ( string-equal ( subseq s 0 4 ) "red>" )
        ( subseq s 4 )
      )
      ( ( string-equal ( subseq s 0 5 ) "blue>" )
        ( subseq s 5 )
      )
      ( ( string-equal ( subseq s 0 6 ) "green>" )
        ( subseq s 6 )
      )
    )
  )

  ( defmethod tokenize-ref  
    ( ( token-so-far string ) ( c character ) ( s string ) )
    ( cond
      ( ( or ( string-equal s "" ) ( char-equal c #\  ) )
        ( values 
          ( make-instance 'token :name token-so-far :type 'ref )
          ( concatenate 'string ( list c ) s )
        )
      )
      ( ( clay-ref-char-p c )
        ( tokenize-ref
          ( concatenate 'string token-so-far ( list c) )
          ( elt s 0 )
          ( subseq s 1 )
        )
      )
    )     
  )

  ( defconstant *clay-ref-char-string* 
    ( concatenate 'string
      "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
    )
  )

  ( defconstant *clay-id-char-string* 
    ( concatenate 'string
      "abcdefghijklmnopqrstuvwxyz" 
      "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
      "0123456789"
      "()[]{}<>-+*/\?@#"
    )
  )

  ( defmethod clay-id-char-p ( ( c character ) )
    ( > ( count c *clay-id-char-string* :test #'char= ) 0 )
  )
 
  ( defmethod clay-ref-char-p ( ( c character ) )
    ( > ( count c *clay-ref-char-string* :test #'char= ) 0 )
  )

  ( defmethod issue-prompt ( ( gc green-clay ) &aux current-prompt )
    ( terpri )
    ( setf current-prompt ( make-prompt gc ) )
    ( format t "~A" current-prompt )
  )

  ( defmethod make-prompt ( ( gc green-clay ) &aux prompt clay-color clay-current-world )
    ( setf clay-color ( world-name ( clay-standard-world gc ) ) )
    ( setf clay-current-world ( clay-current-world gc ) )
    ( setf prompt "" )
    ( if ( standard-green-clay-world-p gc )
      ( setf prompt ( concatenate 'string clay-color "> " ) )
      ( setf prompt ( concatenate 'string clay-color ">" ( world-name clay-current-world  ) "> " ) )
    )
  )

  ( defmethod standard-green-clay-world-p ( ( gc green-clay ) &aux cc w )
    ( setf cc (string ( string-downcase ( clay-color gc ) ) ) )
    ( setf w ( clay-current-world gc ) )
    ( string= cc ( string ( world-name w ) ) )
  )

  ( defmethod last-char-is-period ( ( s string ) )
    ( and
      ( > ( length s ) 0 )
      ( char-equal ( elt s ( - ( length s ) 1 ) ) #\. )
    )
  )

  ( defmethod strip-blanks ( ( s string ) )
    ( strip-leading-blanks ( strip-trailing-blanks s ) )
  )

  ( defmethod strip-trailing-blanks ( ( s string ) )
    ( setf r ( reverse s ) )
    ( setf x ( strip-leading-blanks r ) )
    ( reverse x )
  )

  ( defmethod strip-leading-blanks ( ( s string ) )
    ( cond
      ( ( = ( length s ) 0 )
        ""
      )
      ( ( char-equal ( elt s 0 ) #\  )
        ( strip-leading-blanks ( subseq s 1 ) )
      )
      (
        t
        s
      )
    )
  )

;------------------------------------------------------------
; Green Clay Command Functionality

;  ( defmethod display-gcc ( ( os t ) ( c green-clay-command ) )
;    ( write-line "GREEN CLAY COMMAND" os )
;    ( princ "| " os )
;    ( princ ( clay-command-name c )os  )
;    ( terpri os )
;  )

  ( defmethod display-for-pt ( ( os t ) ( n number ) ( c green-clay-command ) )
    ( print-prefix os n )
    ( write-line "GREEN CLAY COMMAND" os )
    ( print-prefix os ( + n 1 ) )
    ( princ ( clay-command-name c ) os )
    ( terpri os )
  )

  ( defmethod command-equal 
      ( ( c1 green-clay-command ) ( c2 green-clay-command ) &aux n1 n2 )
    ( setf n1 ( clay-command-name c1 ) )
    ( setf n2 ( clay-command-name c2 ) )
    ( string-equal n1 n2 )
  )

  ( defmethod find-green
    ( ( name string ) ( d green-clay-world ) 
      &aux commands c
    )
    ( setf commands ( world-x-commands d ) )
    ( dolist ( c commands )
      ( if ( string= name ( clay-command-name c ) )
        ( return-from find-green c )
      )
    )
    NIL
  )

  ( defmethod find-command
    ( ( c green-clay-command ) ( d green-clay-world ) )
    ( or
      ( find-green ( clay-command-name c ) d ) 
    )

  )

  ( defmethod recursive-find-command 
    ( ( c green-clay-command ) ( d green-clay-world ) )
 
    ( if ( find-command c d )
      ( return-from recursive-find-command d )
    )
    ( if ( null ( world-parent d ) )( return-from recursive-find-command NIL ) )
    ( recursive-find-command c ( world-parent d ) )

  )
    

  ( defmethod determine-full-command-spec
    ( ( gc green-clay )( c green-clay-command ) )
  
    ( setf d ( recursive-find-command c ( clay-current-world gc ) ) )
    ( if ( null d ) ( throw 'unknown-command nil ) )
    ( setf cmd ( find-green ( clay-command-name c ) d ) )
    ( if ( not ( null cmd ) ) 
      ( return-from determine-full-command-spec
        ( make-instance 'full-command-spec :world d :command cmd )
      )
    )
    ( error )
  )

  ( defmethod add
    ( ( gc green-clay ) ( c green-clay-command ) ( d green-clay-world ) )

    ( push c ( world-x-commands d ) )

  )

  ( defmethod make-green-clay-command ( ( n string ) ( d string ) )
    ( setf c ( make-instance 'green-clay-command 
                             :name n :description d 
             ) 
    )
  )

  ( defmethod display-gcc ( (os t )( c green-clay-command ) )
    ( display-naturally os ( clay-command-name c ) )
    ( cond 
      ( ( not ( string-equal 
                ( clay-command-description c ) 
                "" 
              )
        )
        ( princ " -- " os )
        ( princ ( clay-command-description c ) os )
        ( terpri os )
      )
    )
  )

  ( defmethod display-name ( (os t)( c green-clay-command ) &aux s )
    ( setf s ( clay-command-name c ) )
    ( princ s os )
    ( terpri os )
  )

;------------------------------------------------------------
; Modeling a FULL-COMMAND-SPEC

  ( defmethod full-world-name ( ( fcs full-command-spec ) )
    ( world-name 
      ( full-command-spec-world fcs ) 
    )
  )

  ( defmethod display-fcs ( (os t) ( fcs full-command-spec ) )
    ( princ ( world-name 
              ( full-command-spec-world fcs ) 
            ) os 
    )
    ( terpri os )
  )

;  ( defmethod display-fcs ( (os t) ( fxcs full-command-spec ) )
;    ( call-next-method )
;    ( display ( full-command-spec-command fxcs ) os )
;    ( terpri os )
;  )

  ( defmethod rel-command-name ( ( s full-command-spec ) )
    ( clay-command-name 
      ( full-command-spec-command s ) 
    )
  )

  ( defmethod full-command-name ( ( s full-command-spec ) )
    ( setf wn ( full-world-name s ) )
    ( setf cn ( rel-command-name s ) )
    ( if  ( or ( string= wn ( string-downcase "green" ) ) 
               ( string= wn ( string-downcase "red" ) ) 
               ( string= wn ( string-downcase "blue" ) ) 
               ( string= wn ( string-downcase "indigo" ) ) 
          )
      ( concatenate 'string ">" cn )
      ( concatenate 'string wn ">" cn )
    )
  )

  ( defmethod display-naturally ( ( os t ) ( s string ) )
    ( setf *domain* "" )
    ( setf prefix ( concatenate 'string *domain* ">" ) )
    ( cond
      ( ( and 
          ( >= ( length s ) ( length prefix ) )
          ( string-equal
            prefix
            ( subseq s 0 ( + ( length *domain* ) 1 ) )
          )
        )
        ( princ ( subseq s ( + ( length *domain* ) 1 ) ) os  )
      )
      ( t
        ( princ s os  )
      )
    )
  )


;------------------------------------------------------------
; Green Clay Command World Functionality

  ( defmethod display-gcw ( ( os t ) ( cd green-clay-world ) )

    ( display-name os cd )
    ( display-green os cd )

  )


  ( defmethod display-name ( ( os t )  ( cd green-clay-world ) )

    ( terpri os )
    ( princ ( world-name cd ) os )
    ( princ " world" os )
    ( terpri os )

  )

  ( defmethod display-green ( ( os t ) ( cd green-clay-world ) )
    ( dolist ( c ( world-x-commands cd ) )
      ( display-gcc os c )
    )
  )

  ( defmethod order-green
    ( ( f green-clay-world ) )

    ( setf ( world-x-commands f )
           ( sort ( world-x-commands f ) 
                  #'string< :key #'clay-command-name 
           )
    )

  )


;------------------------------------------------------------
; GREEN CLAY INTERPRETER

  ( defmethod load-string ( ( gc green-clay ) ( domain-name string ) &aux file-name-root )
    ( setf file-name-root
      ( concatenate 'string 
        "/home/blue/public_html/ai/lisp/clos/clay/" 
        ( string-downcase ( string (clay-color gc) ) )
        "/domains/"
      ) 
    )
    ( setf lisp-domain-loaded ( load-lisp-domain gc file-name-root domain-name ) )
    NIL
  )

  ( defmethod unload-string (  ( gc green-clay ) ( domain-name string ) )
    ( setf ( clay-current-world gc ) ( clay-standard-world gc ) )
  )


  ( defmethod run ( ( gc green-clay ) )
    ( catch 'terminate-clay
      ( interpret gc )
    )
  )

  ( defmethod run-string ( ( gc green-clay ) ( s string ) )
    ( setf ( reader-input-stream ( clay-reader gc ) ) ( make-string-input-stream s ) )
    ( catch 'terminate-clay
      ( interpret-without-prompt gc )
    )
    ( setf ( reader-input-stream ( clay-reader gc ) ) *terminal-io* )
    NIL
  )

  ( defmethod interpret ( ( gc green-clay ) &aux os )
    ( setf os (clay-output-stream gc ) )
    ( catch 'invalid-lexical-input
      ( read-and-process-instruction gc )
      ( interpret gc )
    )
    ( clay-error gc "Invalid lexical input." )
    ( interpret gc )
  )

  ( defmethod interpret-without-prompt ( ( gc green-clay ) &aux os )
    ( setf os (clay-output-stream gc ) )
    ( catch 'invalid-lexical-input
      ( read-and-process-instruction-without-prompt gc )
      ( interpret-without-prompt gc )
    )
    ( clay-error gc "Invalid lexical input." )
    ( interpret-without-prompt gc )
  )

  ( defmethod read-and-process-instruction ( ( gc green-clay ) &aux tl os )
    ( setf os (clay-output-stream gc ) )
    ( read-clay-line gc )
    ( if ( reader-monitor ( clay-reader gc ) ) ( display-reader os ( clay-reader gc ) ) )
    ( setf tl ( reader-tokenized-line ( clay-reader gc ) ) )
    ( catch 'green
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-instruction-from-green gc tl ) 
          ( return-from read-and-process-instruction NIL )
        )
        ( clay-error gc "Unknown command." )
        ( return-from read-and-process-instruction NIL )
      )
      ( clay-error gc "Not a Green Clay form." )
      ( return-from read-and-process-instruction NIL )
    )
    ( return-from read-and-process-instruction NIL )
  )

  ( defmethod read-and-process-instruction-without-prompt ( ( gc green-clay ) &aux tl os )
    ( setf os (clay-output-stream gc ) )
    ( read-clay-line-without-prompt gc )
    ( if ( reader-monitor ( clay-reader gc ) ) ( display-reader os ( clay-reader gc ) ) )
    ( setf tl ( reader-tokenized-line ( clay-reader gc ) ) )
    ( catch 'green
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-instruction-from-green gc tl ) 
          ( return-from read-and-process-instruction-without-prompt NIL )
        )
        ( clay-error gc "Unknown command." )
        ( return-from read-and-process-instruction-without-prompt NIL )
      )
      ( clay-error gc "Not a Green Clay form." )
      ( return-from read-and-process-instruction-without-prompt NIL )
    )
    ( return-from read-and-process-instruction-without-prompt NIL )
  )

  ( defmethod try-instruction-from-green ( ( gc green-clay ) ( tl list ) )

    ( setf os ( clay-output-stream gc ) )
    ( setf s ( make-instance 'scanner :token-line tl ) )
    ( setf gc-parser ( make-instance 'green-parser :scanner s ) )
    ( catch 'invalid-green-clay-form
      ( parse-monitor-announcement gc "Green" )
      ( parse gc gc-parser )
      ( parse-monitor-output gc "Green" "succeeded" )
      ( if ( clay-parser-monitor gc ) ( display-parse-tree os gc-parser ) )
      ( setf gc-processor 
        ( make-instance 'green-processor :parser gc-parser )
      )
      ( setf name 
        ( catch 'invalid-green-clay-command
          ( process gc gc-processor )
          ( return-from try-instruction-from-green NIL )
        ) 
      )
      ( clay-error gc 
        ( concatenate 'string "\"" name "\""
          " is not a recognizeble Green Clay command."
        )
      )
      ( throw 'green NIL )
    )
    ( parse-monitor-output gc "Green" "failed" )
    ( throw 'not-of-green-clay-form NIL )
  )

  ( defmethod parse ( ( gc green-clay ) ( p green-parser ) &aux os )
    ( setf os ( clay-output-stream gc ) )
    ( setf s ( parser-scanner p ) )
    ( scan os s ( clay-parser-monitor gc ) )
    ( if ( not ( eq ( token-type ( current-token s ) ) 'left-bracket ) )
      ( throw 'invalid-green-clay-form NIL ) 
    )
    ( scan os s ( clay-parser-monitor gc ) )
    ( if ( eq ( token-type ( current-token s ) ) 'id )
      ( setf ( parser-parse-tree p )
             ( make-instance 'green-clay-command 
               :name ( token-name ( current-token s ) ) 
             )
      )
      ( throw 'invalid-green-clay-form NIL ) 
    )
    ( scan os s ( clay-parser-monitor gc ) )
    ( if ( not ( eq ( token-type ( current-token s ) ) 'right-bracket ) )
      ( throw 'invalid-green-clay-form NIL ) 
    )
  )

  ( defmethod process ( ( gc green-clay ) (p green-processor ) &aux gcc)
    ( setf gcc ( parser-parse-tree ( processor-parser p ) ) )
    ( green-clay-eval gc gcc )
    ( setf ( processor-result p ) NIL )
  )


  ( defmethod green-clay-eval 
      ( ( gc green-clay ) ( c green-clay-command ) &aux s rs body os )
    ( setf os ( clay-output-stream gc ) )
    ( setf full-command-spec ( determine-full-command-spec gc c ) )
    ( cond  
      ( ( green-clay-command-p full-command-spec )
        ( setf full-command-name 
           ( full-command-name full-command-spec ) 
        )
        ( setf s ( intern full-command-name ) )
        ( apply s (list gc) )
      )
      ( t
        ( throw 'invalid-green-clay-command ( clay-command-name c ) )
      )
    )
  )

  ( defmethod display-green-commands ( ( os t ) )
    ( display-gcw os *x-world* )
  )

;------------------------------------------------------------
; GREEN CLAY INITIALIZATION 
  
  ( defmethod initialize-gc ( ( gc green-clay ) &aux sw )

  ; establish the standard command green-clay-world
    ( setf sw ( make-instance 'green-clay-world ) )
    ( setf ( world-name sw ) "green" )
    ( setf stop-command 
      ( make-green-clay-command 
        "stop" "Terminate Clay execution."
      )
    )
    ( setf help-command 
      ( make-green-clay-command 
        "help" "Display the commands of the current world."
      )
    )
    ( setf enter-command 
      ( make-green-clay-command 
        "enter" "Enter a world."
      )
    )
    ( setf exit-command 
      ( make-green-clay-command 
        "exit" "Exit the current world, returning to its parent."
      )
    )
    ( setf eval-command 
      ( make-green-clay-command 
        "eval" "Evaluate a Lisp s-expression."
      )
    )
    ( setf monitor-command 
      ( make-green-clay-command 
        "monitor" "Turn on information monitoring feature."
      )
    )
    ( setf unmonitor-command 
      ( make-green-clay-command 
        "unmonitor" "Turn off information monitoring feature."
      )
    )
    ( setf quote-command 
      ( make-green-clay-command 
        "quote" "Display a quote."
      )
    )

    ( setf startmline-command 
      ( make-green-clay-command 
        "startmline" "Start currnet melody line."
      )
    )

    ( setf endmline-command 
      ( make-green-clay-command 
        "endmline" "End current melody line."
      )
    )

    ( setf asc-command 
      ( make-green-clay-command 
        "asc" "Add asc line to current melody line."
      )
    )

    ( setf dsc-command 
      ( make-green-clay-command 
        "dsc" "Add dsc line to current melody line."
      )
    )

    ( add gc stop-command sw )
    ( add gc help-command sw )
    ( add gc quote-command sw )
    ( add gc enter-command sw )
    ( add gc exit-command sw )
    ( add gc eval-command sw )
    ( add gc monitor-command sw )
    ( add gc unmonitor-command sw )
    ( add gc startmline-command sw )
    ( add gc endmline-command sw )
    ( add gc asc-command sw )
    ( add gc dsc-command sw )
    ( order-green sw )
    ( setf ( clay-standard-world gc ) sw )
    ( setf ( clay-current-world gc ) sw )

    ( setf ( clay-reader gc ) ( make-instance 'reader ) )

    NIL
  )

  ( defmethod new-green-clay (&aux gc)
    ( setf gc ( make-instance 'green-clay ) )
    ( initialize-gc gc )
    gc
  )



;------------------------------------------------------------
; Standard Green Clay Commands

  ( defmethod |>stop| ( ( gc green-clay ) )
    ( throw 'terminate-clay  nil )
  )
  
  ( setf *q1* 
"To understand is to invent.  

   - Jean Piaget
      "
  )

  ( setf *q2* 
"It is a characteristic of wisdom not to do desparate things.

   - Henry David Thoreua
      "
  )

  ( setf *q3* 
"Do not become attached to the things you like, 
do not maintain aversion to the things you dislike. 
Sorrow, fear and bondage come from one's likes
and dislikes. 

   - Buddha
      "
  )

  ( setf *q4* 
"
We shall not cease from exploration 
And the end of all our exploring
Will be to arrive where we started
And know the place for the first time.

   - T. S. Eliot
      "
  )
 


  ( setf *quotes* ( list *q1* *q2* *q3* *q4* ) )

  ( defmethod |>quote| ( ( gc green-clay ) )
    ( setf os ( clay-output-stream gc ) )
    ( princ ( nth ( random ( length *quotes* ) )*quotes* ) os )
    ( terpri os )
  )

  ( defmethod |>startmline| ( ( gc green-clay ) )
    ( setf os ( clay-output-stream gc ) )
    ( princ "START A MELODY LINE (MAKE THE STAFF, ETC)" os )
    ( terpri os )
  )

  ( defmethod |>endmline| ( ( gc green-clay ) )
    ( setf os ( clay-output-stream gc ) )
    ( princ "END MELODY LINE (END THE STAFF" os )
    ( terpri os )
  )

  ( defmethod |>asc| ( ( gc green-clay ) )
    ( setf os ( clay-output-stream gc ) )
    ( princ "Add and asc line to current melody" os )
    ( terpri os )
  )

  ( defmethod |>dsc| ( ( gc green-clay ) )
    ( setf os ( clay-output-stream gc ) )
    ( princ "Add and dsc line to current melody" os )
    ( terpri os )
  )

  ( defmethod |>help| ( ( gc green-clay ) )
    ( display-gcw ( clay-output-stream gc ) ( clay-current-world gc ) )
  )

  ( defmethod |>enter| (  ( gc green-clay ) &aux domain-name file-name )
  
    ( write-string "domain? " ( clay-output-stream gc ))
    ( setf domain-name ( strip-blanks ( read-line ) ) )
    ( setf file-name-root
      ( concatenate 'string 
        "/home/blue/public_html/ai/lisp/clos/clay/" 
        ( string-downcase ( string (clay-color gc) ) )
        "/domains/"
      ) 
    )
    ( setf lisp-domain-loaded ( load-lisp-domain gc file-name-root domain-name ) )
  )

  ( defmethod load-lisp-domain 
    ( ( gc green-clay ) ( file-name-root string ) ( domain-name string ) &aux file-name )

    ( setf file-name 
      ( concatenate 'string file-name-root domain-name ".l" )
    )

    ( cond
      ( ( probe-file file-name )
        ( setf *domain* domain-name )
        ( load file-name )
        ( cond 
          ( ( eq ( clay-color gc ) 'green )
            ( setf new-world ( make-instance 'green-clay-world :name domain-name :parent (clay-current-world gc) ) )
          )
          ( ( eq ( clay-color gc ) 'red )
            ( setf new-world ( make-instance 'red-clay-world :name domain-name :parent (clay-current-world gc) ) )
          )
          ( ( eq ( clay-color gc ) 'blue )
            ( setf new-world ( make-instance 'blue-clay-world :name domain-name :parent (clay-current-world gc) ) )
          )
          ( ( eq ( clay-color gc ) 'indigo )
            ( setf new-world ( make-instance 'indigo-clay-world :name domain-name :parent (clay-current-world gc) ) )
          )
        )
        ( setf ( world-x-commands new-world ) ( green-clay-command-family-commands *domain-family* ) )
        ( setf ( clay-current-world gc )  new-world )
        ( format t "Lisp ~A world loaded."
          domain-name ( clay-output-stream gc )
        )
        ( terpri ( clay-output-stream gc ))
        t
      )
      ( t
        ( clay-error gc "No such domain." )
        ( throw ( clay-color gc ) NIL )
         NIL
      )
    )

  )

  ( defmethod |>exit| (  ( gc green-clay ) &aux domain-name)
    ( setf domain-name ( world-name ( clay-current-world gc ) ) )
    ( setf domain-name domain-name )
    ( setf ( clay-current-world gc ) ( clay-standard-world gc ) )
    ( format t "~A world exited."
      domain-name
    )
    ( terpri )
  )

  ( defmethod |>eval| ( ( gc green-clay ) &aux s v )

    ( write-string "blue: s-expression? " )
    ( setf s ( read ) )
    ( setf v ( eval s ) )
    ( prin1 v )
    ( terpri )
  )

  ( defmethod |>monitor| ( ( gc green-clay ) &aux s v )
    
    ( write-string "blue: (reader|parser)? " )
    ( setf s ( read ) )
    ( cond
      ( ( eq s 'reader )
        ( setf ( reader-monitor ( clay-reader gc ) ) t )
        ( setf ( clay-parser-monitor gc ) NIL )
      )
      ( ( eq s 'parser )
        ( setf ( reader-monitor ( clay-reader gc ) ) NIL )
        ( setf ( clay-parser-monitor gc ) t )
      )
      (
        t
        ( write-string "Sorry - do not know how to monitor that." )
      )
    )
    ( terpri )
  )

  ( defmethod |>unmonitor| ( ( gc green-clay ) &aux s v )
     ( setf ( reader-monitor ( clay-reader gc ) )  nil )
     ( setf  ( clay-parser-monitor gc ) nil )
  )











;------------------------------------------------------------
; Green Clay Command Family Functionality

  ( defmethod order
    ( ( f green-clay-command-family ) )

    ( setf ( green-clay-command-family-commands f )
           ( sort ( green-clay-command-family-commands f ) 
                  #'string< :key #'clay-command-name 
           )
    )
  )

  ( defmethod add-command
    ( ( c green-clay-command ) ( f green-clay-command-family ) )

    ( push c ( green-clay-command-family-commands f ) )
  )

  ( defmethod display-gccf ( ( os t ) ( cf green-clay-command-family ) )
    ( terpri os )
    ( princ ( string-upcase ( green-clay-command-family-name cf ) ) os )
    ( princ " family" os )
    ( terpri os )
    ( dolist ( x ( green-clay-command-family-commands cf ) )
      ( display-gcc os x )
    )
  )

  ( defmethod in
      ( ( c green-clay-command ) 
        ( cf green-clay-command-family ) 
      )
    ( member c ( green-clay-command-family-commands cf ) 
      :test #'command-equal 
    )
  )

;------------------------------------------------------------
; Some Parser Monitor Stuff

  ( defmethod parse-monitor-announcement ( ( gc green-clay ) (s string) )
    ( if ( clay-parser-monitor gc )
      ( let () 
        ( format t "Parsing a ~A Clay command." s )
        ( terpri )
      )
    )      
  )

  ( defmethod parse-monitor-output ( ( gc green-clay ) (s string) (o string) )
    ( if ( clay-parser-monitor gc )
      ( let () 
        ( format t "~A Clay command parse ~A." s o )
        ( terpri )
      )
    )      
  )

;------------------------------------------------------------
; Clay Error Reporter

  ( defmethod clay-error ( (gc green-clay) ( s string ) &aux os)
    ( setf os ( clay-output-stream gc ) )
    ( princ ( make-prompt gc ) os ) 
    ( write-line s os )
  )