;------------------------------------------------------------
; File:  indigoclay.l of indigo of clay of clos of lisp of ai

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

;------------------------------------------------------------
; Required packages
  ( load "../blue.l" )
  ( load "../clay/clay.l" )
  ( load "../green/greenclay.l" )
  ( load "../red/redclay.l" )
  ( load "../blue/blueclay.l" )
  ( load "../../combos/cwForClay.l" )

  ;(load "/usr/local/cmn/all.lisp")

  ( defclass indigo-clay
    (blue-clay)
    ()
  )

  ( defclass indigo-clay-world
    (blue-clay-world) 
    ()
  )

  ( defclass indigo-clay-command 
    ( blue-clay-command ) 
    ()
  )

;------------------------------------------------------------
; Modeling a BLUE CLAY COMMAND

  ( defclass indigo-parser
    (parser)
    ()
  )

  ( defclass indigo-processor
    (processor)
    ()
  )

  ( defmethod display-for-pt ( ( os t ) ( n number ) ( b indigo-clay-command ) )
    ( print-prefix os n )
    ( write-line "INDIGO CLAY COMMAND" os )
    ( display-for-pt os ( + n 1 ) ( clay-command-name b ) ) 
    ( display-for-pt os ( + n 1 ) ( clay-command-block b ) ) 
    ;( terpri os )
  )

;------------------------------------------------------------
; BLUE CLAY INTERPRETER

  ( defmethod load-string ( ( gc indigo-clay ) ( domain-name string ) &aux file-name-root )
    ( setf file-name-root
      ( concatenate 'string 
        "/home/blue/public_html/cogmuz/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 indigo-clay ) ( domain-name string ) )
    ( setf ( clay-current-world gc ) ( clay-standard-world gc ) )
  )

  ( defmethod run ( ( bc indigo-clay ) )
    ( catch 'terminate-clay
      ( interpret bc )
    )
  )

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

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

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

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

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


  ( defmethod try-green-instruction-from-indigo
      ( ( bc indigo-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 bc "Green" )
      ( parse bc gc-parser )
      ( parse-monitor-output bc "Green" "succeeded" )
      ( if ( clay-parser-monitor bc ) ( display-parse-tree os gc-parser ) )

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

  )



    
  ( defmethod try-red-instruction-from-indigo ( ( bc indigo-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 bc "Red" )
      ( parse bc rc-parser )
      ( parse-monitor-output bc "Red" "succeeded" )
      ( if ( clay-parser-monitor bc ) ( display-parse-tree os rc-parser ) )
      ( setf rc-processor 
        ( make-instance 'red-processor :parser rc-parser )
      )
      ( catch 'invalid-red-clay-command
        ( process bc rc-processor )
        ( return-from try-red-instruction-from-indigo NIL )
      )
      ( clay-error bc "Red Clay form could not be processed." )
      ( throw 'indigo NIL )
    )
    ( parse-monitor-output bc "Red" "failed" )
    ( throw 'not-of-red-clay-form NIL )

  )


  ( defmethod try-indigo-instruction-from-indigo
    ( ( bc indigo-clay ) ( tl list ) &aux s bc-parser bc-processor )

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


  ( defmethod parse ( ( bc indigo-clay ) ( p indigo-parser ) &aux tl gc-parser rc-parser os )

    ( setf os ( clay-output-stream bc ) )
    ( setf s ( parser-scanner p ) )

    ( scan os s ( clay-parser-monitor bc ) )
    ( if ( not ( eq ( token-type ( current-token s ) ) 'left-bracket ) )
      ( throw 'invalid-blue-clay-form NIL )
    )

    ( setf gc-parser 
      ( make-instance 'green-parser :scanner s ) 
    )
    ( catch 'invalid-green-clay-form
      ( parse-monitor-announcement bc "Green" )
      ( parse bc gc-parser )
      ( parse-monitor-output bc "Green" "succeeded" )
      ( if ( clay-parser-monitor bc ) ( display-parse-tree os gc-parser ) )

      ( scan os s ( clay-parser-monitor bc ) )
      ( if ( not ( eq ( token-type ( current-token s ) ) 'equal-sign ) )
        ( throw 'invalid-blue-clay-form NIL )
      )
      
      ( setf rc-parser 
        ( make-instance 'red-parser :scanner s ) 
      )
      ( catch 'invalid-red-clay-form
        ( parse-monitor-announcement bc "Red" )
        ( parse bc rc-parser )
        ( parse-monitor-output bc "Red" "succeeded" )
        ( if ( clay-parser-monitor bc ) ( display-parse-tree os rc-parser ) )

        ( scan os s ( clay-parser-monitor bc ) )
        ( if ( not ( eq ( token-type ( current-token s ) ) 'right-bracket ) )
          ( throw 'invalid-blue-clay-form NIL )
        )
        ( setf ( parser-parse-tree p )
                ( make-instance 'indigo-clay-command 
                  :name ( clay-command-name ( parser-parse-tree gc-parser ) )
                  :block ( parser-parse-tree rc-parser )
                )
        )
        ( return-from parse NIL )


      )
      ( throw 'invalid-blue-clay-form NIL )
    )
    ( throw 'invalid-blue-clay-form NIL )

  )




  ( defmethod process ( ( gc indigo-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 determine-full-command-spec
    ( ( gc indigo-clay )( c green-clay-command ) &aux base-command-name repetition-factor )
    ( setf base-command-name ( get-base-command-name ( clay-command-name c ) ) )
    ( setf basic-green-clay-command ( make-instance 'green-clay-command :name base-command-name ) )
    ( setf d ( recursive-find-command basic-green-clay-command ( clay-current-world gc ) ) )
    ( if ( null d ) ( throw 'unknown-command nil ) )
    ( setf cmd ( find-blue ( clay-command-name basic-green-clay-command ) d ) )
    ( if ( not ( null cmd ) ) 
      ( return-from determine-full-command-spec
        ( make-instance 'full-command-spec :world d :command cmd )
      )
    )
    ( setf cmd ( find-green ( clay-command-name basic-green-clay-command ) d ) )
    ( if ( not ( null cmd ) ) 
      ( return-from determine-full-command-spec
        ( make-instance 'full-command-spec :world d :command cmd )
      )
    )
    ( error )
  )

  ( defmethod green-clay-eval 
      ( ( gc indigo-clay ) ( c green-clay-command ) &aux s rs body os k base-command-name repetition-factor )
    ( setf os ( clay-output-stream gc ) )
    ( setf repetition-factor ( get-repetition-factor ( clay-command-name c ) ) )
    ( setf base-command-name ( get-base-command-name ( clay-command-name c ) ) )
    ( 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 ) 
        )
        ;( princ "full-command-name= " ) ( princ full-command-name ) ( terpri )
        ;( princ "repetition-factor= " ) ( princ repetition-factor  ) ( terpri )
        ( setf s ( intern full-command-name ) )
        ( dotimes ( k repetition-factor )
          ( apply s (list gc) )
        )
      )
      ( ( blue-clay-command-p full-command-spec )
        ( setf body ( get-assoc-red-clay-command base-command-name ( full-command-spec-world full-command-spec ) ) )
        ( catch 'invalid-red-clay-command
          ( dotimes ( k repetition-factor )
            ( red-clay-eval  gc body )
          )
          ( return-from green-clay-eval NIL )
        )
        ( setf s ( clay-command-name c ) )
        ( clay-error gc 
          ( concatenate 'string "\"" s "\"" 
            " is a referentially corrupt Indigo Clay command definition."
          )
        )
      )
      ( t
        ( throw 'invalid-green-clay-command ( clay-command-name c ) )
      )
    )
  )

  ( defmethod char-is-digit-p ( ( c character ) )
    ( position c "0123456789" :test #'char= )
  )

  ( defmethod char-is-not-digit-p ( ( c character ) )
    ( not ( char-is-digit-p c ) )
  )

  ( defmethod position-of-first-non-digit ( ( s string ) )
    ( if ( char-is-not-digit-p ( elt s 0 ) )
      0
      ( + 1 ( position-of-first-non-digit ( subseq s 1 ) ) )
    )
  )

  ( defmethod position-of-star ( ( s string ) &aux x )
    ( setf x ( position #\* s ) )
    ( cond 
      ( ( null x )
        0
      )
      ( t
        x
      )
    )
  )



  ( defmethod get-base-command-name ( ( name string ) &aux rbname rname p )
    ( setf rname ( reverse name ) )
    ( setf p ( position-of-star rname ) )
    ( cond   
      ( ( = p 0 )
        name
      )
      ( t
        ( setf rbname ( subseq rname ( + p 1 ) ) )
        ( reverse rbname )
      )
    )
  )

  ( defmethod get-repetition-factor ( ( name string ) &aux p rnumber rname)
    ( setf rname ( reverse name ) )
    ( setf p ( position-of-star rname ) )
    ( cond   
      ( ( = p 0 )
        1
      )
      ( t
        ( setf rnumber ( subseq rname 0 p ) )
        ( parse-integer ( reverse rnumber ) )
      )
    )
  )



  ( defmethod process ( ( rc indigo-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 indigo-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 )
  )


  ( defmethod process ( ( bc indigo-clay ) (p indigo-processor ) &aux bcc)
    ( setf bcc ( parser-parse-tree ( processor-parser p ) ) )
    ( indigo-clay-eval bc bcc )
    ( setf ( processor-result p ) NIL )
  )


  ( defmethod indigo-clay-eval 
    ( ( bc indigo-clay ) ( c indigo-clay-command ) &aux s name commands cmd )

    ( catch 'invalid-indigo-clay-command
      ( setf gcc ( clay-command-name c ) )
      ( setf new-command-name gcc )

      ( setf cmd ( find-blue new-command-name ( clay-current-world bc ) ) )

      ( if ( not ( null cmd ) ) 
        ( delete-indigo-command cmd )
      )
      ( add bc c ( clay-current-world bc ) )
      ( return-from indigo-clay-eval NIL )
    )
    ( clay-error "Indigo Clay command execution interrupted." )    
  )

;------------------------------------------------------------
; INDIGO CLAY INITIALIZATION 
  
  ( defmethod initialize-ic (( bc indigo-clay ) &aux rcw sw)
    ( setf rcw ( make-instance 'blue-clay ) )
    ( initialize-bc rcw )
    ( setf sw ( make-instance 'indigo-clay-world ) )
    ( setf ( world-name sw ) "indigo" )
    ( setf ( world-parent sw ) ( world-parent ( clay-standard-world rcw ) ) )
    ( setf ( world-x-commands sw ) ( world-x-commands ( clay-standard-world rcw ) ) )
    ( setf ( world-blue-commands sw ) nil )
    ( setf ( clay-standard-world bc ) sw )
    ( setf ( clay-current-world bc ) sw )

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

    ( setf ( clay-color bc ) 'indigo )

    NIL
  )

  ( defmethod new-indigo-clay (&aux bcc)
    ( setf bc ( make-instance 'indigo-clay ) )
    ( initialize-ic bc )
    bc
  )




;------------------------------------------------------------
; Indigo ...



  ( defmethod |>display| ( ( bc indigo-clay ) &aux command-name cn command-set &aux cname )
    ( write-string "indigo: command? " ( clay-output-stream bc ) )
    ( setf command-name ( strip-blanks ( read-line ) ) )
    ( setf command-set ( command-set bc command-name ) )
    ( cond
      ( ( null command-set )
        ( clay-error bc "No such command to display." )
        ( throw ( clay-color bc ) NIL )
      )
      ( t
        ( dolist ( c command-set )
          ( display-naturally-blue-names bc c )
        )
        ( terpri )
      )
    )
  )
  
  ( defmethod |>sigma| 
    ( ( bc indigo-clay ) &aux command-name cn command-set factor1 factor2 bodies lengths
           triangles sigma disembodied-bodies os
    )
    ( setf os ( clay-output-stream bc ) )
    ( write-string "indigo: command? " os )
    ( setf command-name ( strip-blanks ( read-line ) ) )
    ( setf command-set ( command-set bc command-name ) )
    ( cond 
      ( ( null command-set )
        ( clay-error bc "No such command to analyze." )
        ( throw ( clay-color bc ) NIL )
      )
      ( t
        ( setf factor1 ( * ( length command-set ) 5 ) )
        ( setf bodies ())
        ( dolist ( c command-set )
          ( setf bodies ( cons ( get-assoc-red-clay-command c ( clay-current-world bc ) ) bodies ) )
        )
        ( setf disembodied-bodies ( mapcar #'clay-command-block bodies ) )
        ( setf lengths ( mapcar #'length disembodied-bodies ) )
        ( setf triangles ( mapcar #'triangular-number lengths ) )
        ( setf factor2 ( apply #'+ triangles ) )
        ( setf sigma ( + factor1 factor2 ) )
        ( prin1 sigma os )
        ( terpri os )
      )
    )
  )

  ( defmethod |>sigma-x| 
    ( ( bc indigo-clay ) &aux command-name cn command-set factor1 factor2 bodies lengths
           triangles sigma disembodied-bodies os
    )
    ( setf os ( clay-output-stream bc ) )
    ( write-string "indigo: command? " os )
    ( setf command-name ( strip-blanks ( read-line ) ) )
    ( setf command-set ( command-set bc command-name ) )
    ( cond
      ( ( null command-set )
        ( clay-error bc "No such command to analyze" )
        ( throw ( clay-color bc ) NIL )
      )
      ( t
        ( terpri os )
        ( princ "   command set is " os ) 
        ( display-command-set os command-set )
        ( terpri os )
        ( princ "   command set length is " os )
        ( prin1 ( length command-set ) os )
        ( terpri os )
        ( terpri os ) 
        ( setf factor1 ( * ( length command-set ) 5 ) )
        ( setf bodies ())
        ( dolist ( c command-set )
          ( setf bodies ( cons ( get-assoc-red-clay-command c ( clay-current-world bc ) ) bodies ) )
        )
        ( princ "   command set commands are ..." os ) ( terpri os )
        ( dolist ( c command-set )
          ( princ "   " os )( display-naturally-blue-names bc c )
        )
        ( terpri os )
;        ( mapcar #'display-blue-naturally ( make-list ( length command-set ) :initial-element bc ) command-set bodies )
        ( setf disembodied-bodies ( mapcar #'clay-command-block bodies ) )
        ( setf lengths ( reverse ( mapcar #'length disembodied-bodies ) ) )
        ( princ "   lengths are " os ) ( prin1 lengths os ) ( terpri os )
        ( setf triangles ( mapcar #'triangular-number lengths ) )
        ( princ "   triangular values are " os ) ( prin1 triangles os ) ( terpri os ) ( terpri os )
        ( setf factor2 ( apply #'+ triangles ) )
        ( format t "   factor1 is ~A (5 times the command set length)" factor1 ) 
        ( terpri )
        ( format t "   factor2 is ~A (the sum of the triangular numbers)" factor2 ) 
        ( terpri ) ( terpri ) 
        ( setf sigma ( + factor1 factor2 ) )
        ( format t "   sigma is ~A" sigma )
        ( terpri )
      )
    )
  )

; creat a list of blue-clay-command s
  ( defmethod command-set 
    ( ( bc indigo-clay ) ( cn string ) &aux cmd commands cmd-name bn )

    ( setf bn ( get-base-command-name cn ) )
    ( setf cmd ( find-blue bn ( clay-current-world bc ) ) )

    ( cond
      ( ( not ( null cmd ) )
        ( setf cmd-name ( clay-command-name cmd ) )
        ( setf result ( list cmd-name ) )
        ( setf result ( extend-command-set bc result ) )
        ( reverse result )
      )
      ( t
        NIL
      )
    )

  )
  
  ( defmethod extend-command-set 
    ( ( bc indigo-clay ) ( s list ) &optional ( r '() ) &aux c commands cmd bn )

    ( if ( null s ) ( return-from extend-command-set ( reverse r ) ) )
    ( setf c ( first s ) )
    ( setf s ( rest s ) )
    ( setf bn ( get-base-command-name c ) )
    ( setf cmd ( find-blue bn ( clay-current-world bc ) ) )

    ( cond
      ( ( null cmd )
        ( extend-command-set bc s r )
      )
      ( t
        ( if ( not ( member bn r :test #'string-equal ) ) ( setf r ( append r ( list bn ) ) ) )
        ( setf body ( clay-command-block cmd ) )
        ( setf new ( command-names body ) )
        ( setf s ( add-as-sets s ( make-set new ) ) )
        ( extend-command-set bc s r )
      )
    )
  )



  ( load "/home/blue/cmn/cmn-all.lisp" )
  ;( in-package :cmn )