;;;; -*- mode: scheme -*- ;;;;

;;;; ATTRIBUTES

(define attribute-list
  ;; Consumes, for example, COLOR SIZE AND WEIGHT
  (define-tree
    '(branch
      ((attribute --> a) (attribute-list --> a-list) rtn (cons a a-list))
      (and (attribute --> a) rtn (list a))
      ((attribute --> a) rtn (list a)))))

(define attribute
  ;; Consumes, for example, COLOR
  (define-tree
    '(branch (color        rtn 'color)
	     (colors       rtn 'color)		
	     (size         rtn 'size)
	     (sizes        rtn 'size)	
	     (weight       rtn 'weight)
	     (weights      rtn 'weight))))

;;;; ATTRIBUTE VALUES

(define attribute-value-list
  ;; Consumes, for example, LARGE BLACK AND HEAVY
  (define-tree
    '(branch ((attribute-value --> a-v)
	      (attribute-value-list --> a-v-l)
	      rtn (append a-v a-v-l))
	     (and (attribute-value --> a-v) rtn a-v)
	     ((attribute-value --> a-v) rtn a-v))))

(define attribute-value
  ;; Consumes, for example, LARGE
  (define-tree
    '(branch ((size-value --> v) rtn v)
	     ((color-value --> v) rtn v)
	     ((weight-value --> v) rtn v))))

(define size-value
  ;; Consumes, for example, LARGE
  (define-tree
    '(branch (large        rtn '(size eq? large))
	     (medium       rtn '(size eq? medium))
	     (small        rtn '(size eq? small))
	     (tall         rtn '(size eq? tall))
	     (short        rtn '(size eq? short))
	     (wide         rtn '(size eq? wide))
	     (narrow       rtn '(size eq? narrow))
	     (deep         rtn '(size eq? deep))
	     (shallow      rtn '(size eq? shallow)))))

(define color-value
  ;; Consumes, for example, BLACK
  (define-tree
    '(branch (black        rtn '(color eq? black))
	     (white        rtn '(color eq? white))
	     (blue         rtn '(color eq? blue))
	     (red          rtn '(color eq? red))
	     (green        rtn '(color eq? green))
	     (yellow       rtn '(color eq? yellow)))))

(define weight-value
  ;; Consumes, for example, HEAVY
  (define-tree
    '(branch (heavy        rtn '(weight eq? heavy))
	     (light        rtn '(weight eq? light)))))

;;;; OBJECTS

(define object-description
  ;; Consumes, for example, A BIG BLACK HEAVY BLOCK
  (define-tree
    '(branch ((determiner) (object-description --> o) rtn o)
	     ((attribute-value-list --> a-v-l)
	      (object-description --> o)
	      rtn `(db-select ,o '(with ,@a-v-l)))
	     ((object --> o) rtn o))))

(define determiner
  ;; Consumes, for example, A 
  (define-tree
    '(branch (a) (the))))

(define object
  ;; Consumes, for example, BLOCK 
  (define-tree
    '(branch (block	rtn '(db-select blocks '()))
	     (blocks	rtn '(db-select blocks '()))
	     (box       rtn '(db-select blocks '(with class eq? box)))
	     (boxes     rtn '(db-select blocks '(with class eq? box)))
	     (ball      rtn '(db-select blocks '(with class eq? ball)))
	     (balls     rtn '(db-select blocks '(with class eq? ball)))
	     (wedge     rtn '(db-select blocks '(with class eq? wedge)))
	     (wedges    rtn '(db-select blocks '(with class eq? wedge)))
	     (brick  	rtn '(db-select blocks '(with class eq? brick)))
	     (bricks 	rtn '(db-select blocks '(with class eq? brick))))))

;;;; MAIN TREE

(define main
  (define-tree
    '(branch
      ;; COUNT THE BLOCKS
      (count (object-description --> o)
	if-end-rtn (db-call `(db-report-count (db-count-items ,o))))
      ;; HOW MANY BLOCKS ARE THERE
      (how many (object-description --> o) are there
	if-end-rtn (db-call `(db-report-count (db-count-items ,o))))
      ;; WHAT COLORS ARE THE BLOCKS
      (what (attribute-list --> a-l) are (object-description --> o)
	if-end-rtn (db-call `(db-show (db-project ,o '(over ,@a-l)))))
      ;; WHAT THE BLOCKS COLORS
      (what are (object-description --> o) (attribute-list --> a-l)
	if-end-rtn (db-call `(db-show (db-project ,o '(over ,@a-l)))))
      ((identify)
	 branch
         ;; IDENTIFY THE BRICKS
	 ((object-description --> o)
	  if-end-rtn (db-call `(db-show ,o)))
         ;; IDENTIFY THE COLORS OF THE BRICKS
	 (the (attribute-list --> a-l) of (object-description --> o)
	  if-end-rtn (db-call `(db-show (db-project ,o '(over ,@a-l))))))
      ;; RANK THE BRICKS BY COLOR
      ((rank) (object-description --> o) by (attribute-list --> a-l)
       if-end-rtn (db-call `(db-show (db-sort ,o '(by ,@a-l)))))
      (stop if-end-rtn 'quit)
      (rtn (format #t "~%Sorry, I do not understand")
	   #f))))

;;;; MISCELLANEOUS

(define (number words)
  ;; Consumes, for example, 3
  (cond ((null? words) #f)
	((number? (first words)) (list (first words) (cdr words)))
	(else #f)))

(define rank
  ;; Consumes, for example, RANK
  (define-tree
    '(branch (rank)
	     (list)
	     (sort))))

(define identify
  ;; Consumes, for example, IDENTIFY
  (define-tree
    '(branch (identify)
	     (describe)
	     (show me all)
	     (show me)
	     (what is)
	     (what are)
	     (who is)
	     (who are)
	     (give)
	     (display)
	     (print)
	     (list)
	     (present)
	     (which))))