;------------------------------------------------------------
; File:  redclay.l of red of clay of clos of lisp of ai

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

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

;------------------------------------------------------------
; Modeling a RED CLAY COMMAND

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defclass red-clay
    (green-clay)
    ()
  )

  ( defclass red-clay-world
    (green-clay-world) 
    ()
  )



  ( defclass red-clay-command
    ( green-clay-command) 
    ( ( block :accessor clay-command-block :initarg :block ) 
    )
  )

  ( defmethod display-rcc ( ( os t ) ( r red-clay-command ) )
    ( write-line "RED CLAY COMMAND"  os )
    ( dolist ( c ( clay-command-block r  ) )
      ;( display-ccb c os )
      (princ "trouble in redclay.") (terpri)
    )
    ( terpri  os )
  )

  ( defmethod display-block-naturally 
    ( ( os t ) ( r red-clay-command ) )

    ( display-block-naturally-helper os ( clay-command-block r ) )

  )

  ( defmethod display-block-naturally-helper
    ( ( os t ) ( l list ) )
    ( cond
      ( ( = ( length l ) 1 )
        ( princ  ( clay-command-name ( first l ) ) os )
        ( princ "." os )
      )
      ( t
        ( princ  ( clay-command-name ( first l ) ) os )
        ( princ ", " os )
        ( display-block-naturally-helper os ( cdr l ) )
      )
    )

  )


  ( defmethod display-for-pt ( ( os t ) ( n number ) ( r red-clay-command ) )
    ( print-prefix os n )
    ( write-line "RED CLAY COMMAND" os )
    ( dolist ( c ( clay-command-block r ) )
      ( display-for-pt os ( + 1 n ) c )
    )
  )

  ( defclass red-parser
    (parser)
    ()
  )

  ( defclass red-processor
    (processor)
    ()
  )



;------------------------------------------------------------
; RED CLAY INTERPRETER

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ( defmethod load-string ( ( gc red-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 red-clay ) ( domain-name string ) )
    ( setf ( clay-current-world gc ) ( clay-standard-world gc ) )
  )

  ( defmethod run ( ( rc red-clay ) )
    ( catch 'terminate-clay
      ( interpret rc )
    )
  )

  ( defmethod run-string ( ( gc red-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 ( ( rc red-clay ) &aux os )
    ( setf os (clay-output-stream rc ) )
    ( catch 'invalid-lexical-input
      ( read-and-process-instruction rc )
      ( interpret rc )
    )
    ( clay-error rc "Invalid lexical input." )
    ( interpret rc )
  )

  ( defmethod interpret-without-prompt ( ( gc red-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 ( ( rc red-clay ) &aux tl os )
    ( setf os (clay-output-stream rc ) )
    ( read-clay-line rc )
    ( if ( reader-monitor ( clay-reader rc ) ) ( display-reader os ( clay-reader rc ) ) )
    ( setf tl ( reader-tokenized-line ( clay-reader rc ) ) )


    ( catch 'red
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-green-instruction-from-red rc tl )
          ( return-from read-and-process-instruction NIL )
        )
        ( clay-error rc "Unknown command." )
        ( return-from read-and-process-instruction NIL )
      )
      ( catch 'not-of-red-clay-form
        ( catch 'unknown-command
          ( try-red-instruction-from-red rc tl )
          ( return-from read-and-process-instruction NIL )
        )
        ( clay-error rc "Unknown command." )
        ( return-from read-and-process-instruction NIL )
      )
      ( clay-error rc "Not of Red Clay form." )
    )
  )

  ( defmethod read-and-process-instruction-without-prompt ( ( rc red-clay ) &aux tl os )
    ( setf os (clay-output-stream rc ) )
    ( read-clay-line-without-prompt rc )
    ( if ( reader-monitor ( clay-reader rc ) ) ( display-reader os ( clay-reader rc ) ) )
    ( setf tl ( reader-tokenized-line ( clay-reader rc ) ) )


    ( catch 'red
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-green-instruction-from-red rc tl )
          ( return-from read-and-process-instruction-without-prompt NIL )
        )
        ( clay-error rc "Unknown command." )
        ( return-from read-and-process-instruction-without-prompt NIL )
      )
      ( catch 'not-of-red-clay-form
        ( catch 'unknown-command
          ( try-red-instruction-from-red rc tl )
          ( return-from read-and-process-instruction-without-prompt NIL )
        )
        ( clay-error rc "Unknown command." )
        ( return-from read-and-process-instruction-without-prompt NIL )
      )
      ( clay-error rc "Not of Red Clay form." )
    )
  )

  ( defmethod try-green-instruction-from-red
      ( ( rc red-clay ) ( tl list ) &aux name s )

    ( 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 rc "Green" )
      ( parse rc gc-parser )
      ( parse-monitor-output rc "Green" "succeeded" )
      ( if ( clay-parser-monitor rc ) ( display-parse-tree os gc-parser ) )

      ( setf gc-processor 
        ( make-instance 'green-processor :parser gc-parser )
      )
      ( setf name 
        ( catch 'invalid-green-clay-command
          ( process rc gc-processor )
          ( return-from try-green-instruction-from-red NIL )
        ) 
      )
      ( clay-error rc
        ( concatenate 'string "\"" name "\""
          " is not a recognizeble Green Clay command."
        )
      )
      ( throw 'red NIL )
    )
    ( parse-monitor-output rc "Green" "failed" )
    ( throw 'not-of-green-clay-form NIL )

  )

    
  ( defmethod try-red-instruction-from-red ( ( rc red-clay ) ( tl list ) &aux s rc-parser rc-processor )

    ( setf s ( make-instance 'scanner :token-line tl ) )
    ( setf rc-parser ( make-instance 'red-parser :scanner s ) )
    ( catch 'invalid-red-clay-form
      ( parse-monitor-announcement rc "Red" )
      ( parse rc rc-parser )
      ( parse-monitor-output rc "Red" "succeeded" )
      ( if ( clay-parser-monitor rc ) ( display-parse-tree os rc-parser ) )
      ( setf rc-processor 
        ( make-instance 'red-processor :parser rc-parser )
      )
      ( catch 'invalid-red-clay-command
        ( process rc rc-processor )
        ( return-from try-red-instruction-from-red NIL )
      )
      ( clay-error rc "Red Clay form could not be processed." )
      ( throw 'red NIL )
    )
    ( parse-monitor-output rc "Red" "failed" )
    ( throw 'not-of-red-clay-form NIL )

  )


  ( defmethod parse ( ( rc red-clay ) ( p red-parser ) &aux os )
    ( setf os ( clay-output-stream rc ) )
    ( setf s ( parser-scanner p ) )
    ( scan os s ( clay-parser-monitor rc ) )
    ( if ( eq ( token-type ( current-token s ) ) 'left-bracket )
       ( let () 
         ( scan os s ( clay-parser-monitor rc ) )
         ( setf gcs ( scan-green-clay-sequence rc s ) )
       )
       ( throw 'invalid-red-clay-form NIL )
    )
    ( if ( eq ( token-type ( current-token s ) ) 'right-bracket )
       ( setf ( parser-parse-tree p )
              ( make-instance 'red-clay-command 
                :block gcs
              )
       )
       ( throw 'invalid-red-clay-form NIL )
    )
  )

  ( defmethod scan-green-clay-sequence 
       ( ( rc red-clay ) ( s scanner ) &optional (result '()) &aux gcc )
    ( setf os ( clay-output-stream rc ) )
    ( if ( eq ( token-type ( current-token s ) ) 'right-bracket )
      ( return-from scan-green-clay-sequence ( reverse result ) )
    )
    ( if ( eq ( token-type ( current-token s ) ) 'left-bracket )
       ( scan os s ( clay-parser-monitor rc ) )
       ( throw 'invalid-red-clay-form NIL )
    )
    ( if ( eq ( token-type ( current-token s ) ) 'id )
       ( let () 
         ( setf gcc ( make-instance 'green-clay-command 
                      :name ( token-name ( current-token s ) )
                    )
         )
         ( scan os s ( clay-parser-monitor rc ) )
       )
       ( throw 'invalid-red-clay-form NIL )
    )
    ( if ( eq ( token-type ( current-token s ) ) 'right-bracket )
       ( scan os s ( clay-parser-monitor rc ) )
       ( throw 'invalid-red-clay-form NIL )
    )
    ( scan-green-clay-sequence rc s ( cons gcc result ) )
  )


  ( defmethod process ( ( rc red-clay ) (p red-processor ) &aux rcc)
    ( setf rcc ( parser-parse-tree ( processor-parser p ) ) )
    ( catch 'invalid-red-clay-command
      ( red-clay-eval rc rcc )
      ( setf ( processor-result p ) NIL )
      ( return-from process NIL )
    )
  )

  ( defmethod red-clay-eval ( ( rc green-clay ) ( c red-clay-command ) &aux name gcc )
      ( setf name 
        ( catch 'invalid-green-clay-command
          ( dolist ( gcc ( clay-command-block c ) )
            ( green-clay-eval rc gcc )
          )
          ( return-from red-clay-eval NIL )
        )
      )
      ( clay-error rc
        ( concatenate 'string 
             "\"" name "\""
             " is not a Green Clay command." 
        )
      )
      ( clay-error rc "Red Clay command execution interrupted." )    
      ( throw 'invalid-red-clay-command NIL )
  )

;------------------------------------------------------------
; RED CLAY INITIALIZATION 
  

  ( defmethod initialize-rc (( rc red-clay ) &aux gcw sw)
    ( setf gcw ( make-instance 'green-clay ) )
    ( initialize-gc gcw )
    ( setf sw ( make-instance 'red-clay-world ) )
    ( setf ( world-name sw ) "red" )
    ( setf ( world-parent sw ) ( world-parent ( clay-standard-world gcw ) ) )
    ( setf ( world-x-commands sw ) ( world-x-commands ( clay-standard-world gcw ) ) )
    ( setf ( clay-standard-world rc ) sw )
    ( setf ( clay-current-world rc ) sw )
    ( setf ( clay-color rc ) 'red )
    ( setf ( clay-reader rc ) ( make-instance 'reader ) )
    NIL
  )

  ( defmethod new-red-clay (&aux rc)
    ( setf rc ( make-instance 'red-clay ) )
    ( initialize-rc rc )
    rc
  )