;------------------------------------------------------------
; File:  blueclay.l of blue of clay of clos of lisp of ai

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

;------------------------------------------------------------
; Requiblue packages
  ;( load "/home/blue/cmn/cmn-all.lisp" )
  ;( in-package :cmn)
  ;( load "../blue.l" )
  ;( load "../clay/clay.l" )
  ;( load "../green/greenclay.l" )
  ;( load "../red/redclay.l" )
  ;( load "../../combos/cwForClay.l" )


;------------------------------------------------------------
; The blue clay code

  ( defclass blue-clay
    (red-clay)
    ( )
  )

  ( defclass blue-clay-world
    (red-clay-world) 
    ( ( blue-commands :accessor world-blue-commands 
                      :initarg :blue-commands :initform '()
      )
    )
  )

  ( defclass blue-clay-command 
    ( red-clay-command ) 
    ( )
  )

  ( defmethod display-bc ( ( bc blue-clay ) ( b blue-clay-command ) &aux os )
    ( setf os ( clay-output-stream bc ) )
    ( write-line "BLUE CLAY COMMAND" os )
    ( princ  ( clay-command-name b ) os) 
    ( princ " = " os)
    ( display-block-naturally ( clay-output-stream bc ) ( clay-command-block b ) )
    ( terpri os )
  )

  ( defmethod display-bcc ( ( os t ) ( b blue-clay-command ) &aux os )
    ( princ  ( clay-command-name b ) os) 
    ( princ " = " os)
    ( display-block-naturally ( clay-output-stream bc ) ( clay-command-block b ) )
    ( terpri os )
  )

  ( defmethod display-for-pt ( ( os t ) ( n number ) ( s string ) )
    ( print-prefix os n )
    ( write-line s os )
  )

  ( defmethod display-for-pt ( ( os t ) ( n number ) ( b blue-clay-command ) )
    ( print-prefix os n )
    ( write-line "BLUE 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 )
  )

  ( defmethod display-bcw ( ( os t ) ( cd blue-clay-world ) )

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

  )

  ( defmethod find-blue
    ( ( name string ) ( d blue-clay-world ) 
      &aux commands cmd
    )

    ( setf commands ( world-blue-commands d ) )
    ( setf cmd
      ( find name commands 
        :test #'string-equal :key #'clay-command-name 
      )
    )
    cmd

  )

  ( defmethod green-clay-command-p ( ( fcs full-command-spec ) &aux name)
    ( setf name ( clay-command-name ( full-command-spec-command fcs ) ) )
    ( find-green name ( full-command-spec-world fcs ) )
  )

  ( defmethod blue-clay-command-p ( ( fcs full-command-spec )&aux name )
    ( setf name ( clay-command-name ( full-command-spec-command fcs ) ) )
    ( find-blue name ( full-command-spec-world fcs ) )
  )




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

  )

  ( defmethod recursive-find-command 
    ( ( c green-clay-command ) ( d blue-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 blue-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-blue ( clay-command-name c ) 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 c ) d ) )
    ( if ( not ( null cmd ) ) 
      ( return-from determine-full-command-spec
        ( make-instance 'full-command-spec :world d :command cmd )
      )
    )
    ( error )
  )

  ( defmethod add
    ( ( bc blue-clay ) ( c blue-clay-command ) ( d blue-clay-world ) )

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

  )

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

  ( defmethod display-naturally ( ( bc blue-clay ) ( c blue-clay-command ) &aux os )
    ( setf os ( clay-output-stream bc ) )
    ( princ ( clay-command-name c ) os )
    ( princ " = " os )
    ( display-block-naturally os ( clay-command-block c ) )
    ( terpri os )
  )


  ( defmethod display-name ( ( os t ) ( c blue-clay-command ) )
    ( princ ( clay-command-name c ) os )
    ( terpri os )
  )

  ( defmethod display-blue ( ( os t ) ( cd blue-clay-world ) )
    ( dolist ( c ( world-blue-commands cd ) )
      ( display-bcc os c )
    )
  )

( defmethod get-assoc-red-clay-command 
  ( ( c green-clay-command ) ( d blue-clay-world ) 
    &aux cmd
  )

  ( clay-command-block ( find-cmd c d ) )

)

( defmethod get-assoc-red-clay-command 
  ( ( cn string ) ( d blue-clay-world ) 
    &aux cmd
  )

  ( clay-command-block ( find-blue cn d ) )

)

( defmethod find-cmd
  ( ( c green-clay-command ) ( d blue-clay-world ) 
    &aux f cmd
  )

  ( setf f ( world-blue-commands d ) )
  ( setf cmd ( find c f :test #'command-equal ) )

  cmd

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

  ( defclass blue-parser
    (parser)
    ()
  )

  ( defclass blue-processor
    (processor)
    ()
  )

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

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

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

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

    ( catch 'blue
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-green-instruction-from-blue 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-blue bc tl )
          ( return-from read-and-process-instruction NIL )
        )
        ( clay-error bc "Unknown command." )
        ( return-from read-and-process-instruction NIL )
      )
      ( catch 'not-of-blue-clay-form
        ( catch 'unknown-command
          ( try-blue-instruction-from-blue 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 Blue Clay form." )
      ( return-from read-and-process-instruction NIL )
    )
  )

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

    ( catch 'blue
      ( catch 'not-of-green-clay-form
        ( catch 'unknown-command
          ( try-green-instruction-from-blue 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-blue 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-blue-clay-form
        ( catch 'unknown-command
          ( try-blue-instruction-from-blue 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 Blue Clay form." )
      ( return-from read-and-process-instruction-without-prompt NIL )
    )
  )

  ( defmethod try-green-instruction-from-blue
      ( ( bc blue-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-blue NIL )
        ) 
      )
      ( clay-error bc
        ( concatenate 'string "\"" name "\""
          " is not a recognizeble Green Clay command."
        )
      )
      ( throw 'blue NIL )
    )
    ( parse-monitor-output bc "Green" "failed" )
    ( throw 'not-of-green-clay-form NIL )

  )



    
  ( defmethod try-red-instruction-from-blue ( ( bc blue-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-blue NIL )
      )
      ( clay-error bc "Red Clay form could not be processed." )
      ( throw 'blue NIL )
    )
    ( parse-monitor-output bc "Red" "failed" )
    ( throw 'not-of-red-clay-form NIL )

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

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

  ( defmethod parse ( ( bc blue-clay ) ( p blue-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 'blue-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 blue-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 blue-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) )
      )
      ( ( blue-clay-command-p full-command-spec )
        ( setf body ( get-assoc-red-clay-command c ( full-command-spec-world full-command-spec ) ) )
        ( catch 'invalid-red-clay-command
          ( 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 Blue Clay command definition."
          )
        )
      )
      ( t
        ( throw 'invalid-green-clay-command ( clay-command-name c ) )
      )
    )
  )


  ( defmethod process ( ( rc blue-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 blue-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 blue-clay ) (p blue-processor ) &aux bcc)
    ( setf bcc ( parser-parse-tree ( processor-parser p ) ) )
    ( blue-clay-eval bc bcc )
    ( setf ( processor-result p ) NIL )
  )


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

    ( catch 'invalid-blue-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-blue-command cmd )
      )
      ( add bc c ( clay-current-world bc ) )
      ( return-from blue-clay-eval NIL )
    )
    ( clay-error "Blue Clay command execution interrupted." )    
  )

;------------------------------------------------------------
; BLUE CLAY INITIALIZATION 
  
  ( defmethod initialize-bc (( bc blue-clay ) &aux rcw sw)
    ( setf rcw ( make-instance 'red-clay ) )
    ( initialize-rc rcw )
    ( setf sw ( make-instance 'blue-clay-world ) )
    ( setf ( world-name sw ) "blue" )
    ( 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 display-command 
      ( make-green-clay-command 
        "display" "Display a Blue Clay command \"completely\"."
      )
    )

    ( setf delete-command 
      ( make-green-clay-command 
        "delete" "Delete a Blue Clay command."
      )
    )

    ( setf sigma-command 
      ( make-green-clay-command 
        "sigma" 
        "Compute a concept metric for a Blue Clay command."
      )
    )

    ( setf sigma-x-command 
      ( make-green-clay-command 
        "sigma-x" 
        "Compute a concept metric for a Blue Clay command and \"show work\"."
      )
    )

    ( add bc display-command sw )
    ( add bc delete-command sw )
    ( add bc sigma-command sw )
    ( add bc sigma-x-command sw )

    ( order-green sw )

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

    ( setf ( clay-color bc ) 'blue )

    NIL
  )

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




  ( defmethod |>delete| ( ( bc blue-clay ) &aux command-name cn command-set )
    ( write-string "blue: command? " )
    ( setf command-name ( strip-blanks ( read-line ) ) )
    ( setf cn ( concatenate 'string ( world-name ( clay-current-world bc ) ) ">" command-name ) )
    ( delete-blue-command bc cn )
    ( terpri )
  )

  ( defmethod |>display| ( ( bc blue-clay ) &aux command-name cn command-set &aux cname )
    ( write-string "blue: 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 blue-clay ) &aux command-name cn command-set factor1 factor2 bodies lengths
           triangles sigma disembodied-bodies os
    )
    ( setf os ( clay-output-stream bc ) )
    ( write-string "blue: 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 blue-clay ) &aux command-name cn command-set factor1 factor2 bodies lengths
           triangles sigma disembodied-bodies os
    )
    ( setf os ( clay-output-stream bc ) )
    ( write-string "blue: 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 )
      )
    )
  )

  ( defmethod display-command-set ( ( os t ) ( cs list ) )
    ( princ "{ " os )
    ( dolist ( c cs )
      ;( display-naturally os c )
      ( princ c os )
      ( princ " " os )
    )
    ( princ "}" os )
  )


  ( defmethod display-blue-naturally 
    ( ( bc blue-clay ) ( gn string ) ( rc red-clay-command ) )
    ( setf os ( clay-output-stream bc ) )
    ( princ "      " os )
    ( display-naturally os gn )
    ( princ " = " os )
    ( display-block-naturally bc rc )
    ( terpri os )
  )

  ( defmethod display-naturally-blue-names 
    ( ( bc blue-clay) ( s string ) &aux commands cmd)

    ( setf cmd ( find-blue  s ( clay-current-world bc ) ) )
    ( display-naturally bc cmd )
  )
    

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

    ( setf cmd ( find-blue cn ( 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 blue-clay ) ( s list ) &optional ( r '() ) &aux c commands cmd )

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

    ( cond
      ( ( null cmd )
        ( extend-command-set bc s r )
      )
      ( t
        ( if ( not ( member c r :test #'string-equal ) ) ( setf r ( append r ( list c ) ) ) )
        ( 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 )
      )
    )
  )

  ( defmethod command-names ( ( rc red-clay-command ) )
    ( mapcar #'clay-command-name ( clay-command-block rc ) )
  )

  ; presume set of string inputs, produce set of string output
  ( defmethod add-as-sets ( ( s1 list ) ( s2 list ) )
    ( if ( null s1 ) ( return-from add-as-sets s2 ) )
    ( setf e ( first s1 ) )
    ( cond
      ( ( member e s2 :test #'string-equal )
        ( add-as-sets ( cdr s1 ) s2 )
      )
      ( t
        ( add-as-sets ( cdr s1 ) ( cons e s2 ) )
      )
    )
  )

  ( defmethod make-set ( ( s list ) )
    ( cond 
      ( ( null s )
        '()
      )
      ( ( member ( first s ) ( rest s ) :test #'string-equal )
        ( make-set ( rest s ) )
      )
      ( t
        ( cons ( first s ) ( make-set ( rest s ) ) )
      )
    )
  )


        
  
        
  ( defmethod delete-blue-command ( ( bc blue-clay ) ( cn string ) &aux d f r )
    ( setf d ( clay-current-world bc ) )
    ( setf f ( world-blue-commands d ) )
    ( setf cname ( subseq cn ( + 1 ( position #\> cn ) ) ) )
    ( setf r 
      ( delete cname f :test #'string-equal :key #'clay-command-name ) 
    )
    ( format t "~A deleted." cname )
    ( setf ( world-blue-commands d ) r )
  )







  ;( load "domains/melody.l")