Vacuum Cleaner

vacuum.rkt

#lang racket

; CS3243 Vacuum Cleaner world simulation using Racket Scheme
; Initially written by Yong Chun How
; Modified by Pang Yan Han

; Helper functions
(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (accumulate op (op (car sequence) initial) (cdr sequence))))


; Vertex - a 3 element list consisting of:
; 1. Location (A symbol)
; 2. Clean or Dirty
; 3. Edges - a list of edges. Each edge is a cons pair
;            of location and direction. Use make-edge (defined below)
;            to create edges
(define (make-vertex loc clean/dirty edges)
  (list loc clean/dirty edges))

(define (make-vertices loclist cleanlist edgelist)
  "Creates a list of vertices. Used to simulate the vacuum cleaner world"
  (map (lambda (loc clean/dirty edges)
         (make-vertex loc clean/dirty edges))
       loclist cleanlist edgelist))

(define vertex-location car)
(define vertex-clean cadr)
(define vertex-edges caddr)

(define (make-edge loc dir)
  (cons loc dir))
(define edge-location car)
(define edge-direction cdr)

(define all-dirty (make-vertices '(A B C D)
                                 '(Dirty Dirty Dirty Dirty)
                                 (list (list (make-edge 'B 'right))
                                       (list (make-edge 'A 'left)
                                             (make-edge 'C 'right))
                                       (list (make-edge 'B 'left)
                                             (make-edge 'D 'right))
                                       (list (make-edge 'C 'left)))))
(define half-dirty (make-vertices '(A B C D)
                                  '(Dirty Clean Dirty Clean)
                                  (list (list (make-edge 'B 'right))
                                        (list (make-edge 'A 'left)
                                              (make-edge 'C 'right))
                                        (list (make-edge 'B 'left)
                                              (make-edge 'D 'right))
                                        (list (make-edge 'C 'left)))))
(define all-clean (make-vertices '(A B C D)
                                 '(Clean Clean Clean Clean)
                                 (list (list (make-edge 'B 'right))
                                       (list (make-edge 'A 'left)
                                             (make-edge 'C 'right))
                                       (list (make-edge 'B 'left)
                                             (make-edge 'D 'right))
                                       (list (make-edge 'C 'left)))))

; Model functions
(define (model-update loc clean/dirty model)
  "Given location and it new clean/dirty status, return a new world"
  (cond ((null? model) null)
        ((eq? loc (vertex-location (car model)))
         (cons (make-vertex loc clean/dirty (vertex-edges (car model)))
               (cdr model)))
        (else
         (cons (car model) (model-update loc clean/dirty (cdr model))))))

(define (model-all-clean? model)
  (accumulate
   (lambda (x y)
     (and x y))
   #t
   (map (lambda (z) (cond
                      ((null? z) empty)
                      ((eq? 'Clean (vertex-clean z)) #t)
                      (else #f)))
        model)))

(define (model-display model)
  (define (md model first)
    (if (null? model)
        (write-char #\newline)
        (let ((vertex (car model)))
          (if first
              (set! first #f)
              (display ", "))
          (display (vertex-location vertex))
          (display ": ")
          (display (vertex-clean vertex))
          (md (cdr model) first))))
  (md model #t))

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

; Percept functions
; Percept = 2 element list, car = location, cadr = cleanliness
(define (make-percept location model)
  (list location (cleanliness-of-location location model)))

(define percept-location car)
(define percept-cleanliness cadr)

(define (location-with-result clean/dirty model)
  (let ((r (filter (lambda (x)
                     (eq? (vertex-clean x) clean/dirty))
                   model)))
    (if (null? r)
        'Nil
        (vertex-location (car r)))))

(define (cleanliness-of-location loc model)
  (let ((lst (memf (lambda (x)
                     (eq? (vertex-location x) loc))
                   model)))
    (if (null? lst) 'Nil
        (vertex-clean (car lst)))))

; Result functions
; Result is a list consisting of a reaction (defined below) and model world
(define (make-result reaction model)
  (list reaction model))
(define result-reaction car)
(define result-model cadr)

; Reaction functions
; Reaction = list of 1 symbol and optional path
; The symbol can be one of no-op or move
; Path should be provided when the symbol is move
(define (make-reaction action path)
  (list action path))
(define reaction-act car)
(define reaction-path cadr)

(define (bfs-dirty location model)
  (define append-q-node cons)
  (define (get-new-paths edges visited path)
    (map (lambda (edge)
           (let* ((next-loc (edge-location edge))
                  (next-lst (memf (lambda (edge)
                                    (eq? (edge-location edge) next-loc))
                                  model)))
             (append-q-node (car next-lst) (append path (list edge)))))
         (filter (lambda (edge)
                   (not (member (edge-location edge) visited)))
                 edges)))
  (define (bfs-i q visited)
    (if (null? q)
        (make-reaction 'no-op null)
        (let* ((top    (car q))
               (rest   (cdr q))
               (vertex (car top))
               (path   (cdr top))
               (edges  (vertex-edges vertex)))
          (if (eq? (vertex-clean vertex) 'Dirty)
              (make-reaction 'move path)
              (bfs-i (append rest (get-new-paths edges visited path))
                     (append-q-node (vertex-location vertex) visited))))))
  
  (let ((lst (memf (lambda (x)
                     (eq? (vertex-location x) location))
                   model)))
    (if (null? lst)
        (make-reaction 'no-op null)
        (bfs-i (list (append-q-node (car lst) null)) null))))

(define (model-reflex-agent percept model)
  "Given a percept and model, returns a result"
  (let ((location (percept-location percept))
        (clean/dirty (percept-cleanliness percept)))
    (cond ((model-all-clean? model)
           (make-result '(no-op) model))
          ((eq? clean/dirty 'Dirty)
           (make-result '(suck) (model-update location 'Clean model)))
          (else
           (make-result (bfs-dirty location model) model)))))

; Printing functions
(define (show-location location)
  (display "Location: ")
  (display location)
  (write-char #\newline))

(define (show-action model action)
  (display "Before Action: ")
  (model-display model)
  (display "Action: ")
  (display action)
  (write-char #\newline))

(define (show-model model)
  (display "After Action: ")
  (model-display model)
  (write-char #\newline))

(define (show-world location model action new-model)
  (show-location location)
  (show-action model action)
  (show-model new-model))

(define (main location model)
  (let* ((result    (model-reflex-agent (make-percept location model) model))
         (reaction  (result-reaction result))
         (action    (reaction-act reaction))
         (new-model (result-model result)))
    (cond
      ((eq? action 'no-op)
       (write-char #\newline))
      ((eq? action 'move)
       (map (lambda (x)
              (show-world location model (edge-direction x) model)
              (set! location (edge-location x)))
            (reaction-path reaction))
       (main (edge-location (last (reaction-path reaction))) model))
      ((eq? action 'suck)
       (show-world location model 'suck new-model)
       (main location new-model)))))

(define (sim)
  (main 'C
        (make-vertices '(A B C D)
                       '(Dirty Clean Clean Dirty)
                       (list (list (make-edge 'B 'right))
                             (list (make-edge 'A 'left)
                                   (make-edge 'C 'right))
                             (list (make-edge 'B 'left)
                                   (make-edge 'D 'right))
                             (list (make-edge 'C 'left))))))