(defclass light (circle)
  ((color-on :initform :green)
   (color-off :initform :gray)
   (onp :initform NIL)))

(defmethod color-on ((l light))
  (slot-value l 'color-on))

(defmethod set-color-on ((l light) color)
  (setf (slot-value l 'color-on) color)
  (assert-color l))

(defmethod color-off ((l light))
  (slot-value l 'color-off))

(defmethod set-color-off ((l light) color)
  (setf (slot-value l 'color-off) color)
  (assert-color l))


(defmethod onp ((l light))
  (slot-value l 'onp))

(defmethod set-onp ((l light) value)
  (setf (slot-value l 'onp) value)
  (assert-color l))

(defmethod assert-color ((l light))
  (set-color l
             (if (onp l)
                 (color-on l)
               (color-off l)))
  l)

(defmethod initialize-instance ((l light) &key)
  (call-next-method)
  (set-radius l 10)
  (set-filledp l T)
  (assert-color l))

(defmethod switch ((l light))
  (set-onp l (not (onp l))))

(defclass traffic-lights
          (picture)
  ((lights :initform NIL)
   (program :initform NIL)
   (position-in-program :initform 0)
   ))

(defmethod lights ((tl traffic-lights))
  (remove-if (lambda(x)
               (not (typep x 'light)))
             (items tl)))

(defmethod program ((tl traffic-lights))
  (slot-value tl 'program))

(defmethod set-program ((tl traffic-lights) value)
  (let ((num-of-lights (length (lights tl))))
    (unless (and (listp value)
                 (every (lambda(v) 
                          (and (listp v)
                               (= (length v) num-of-lights)))
                        value))
      (error "value has to be list of lists whose lengths are equal to number of lights")))

  (setf (slot-value tl 'program)
        value)
  tl)
      
(defmethod reset ((tl traffic-lights))
  (set-position-in-program tl 0))

(defmethod set-position-in-program ((tl traffic-lights) val)
  
  (when (program tl)

    (setf (slot-value tl 'position-in-program)
          (mod val
               (length (program tl))))
    
    (assert-lights tl)))

(defmethod next-position ((tl traffic-lights))
  (set-position-in-program tl
                           (if (program tl)
                               (+ 1 (position-in-program tl))
                             0)))


(defmethod position-in-program ((tl traffic-lights))
  (slot-value tl 'position-in-program))

(defmethod set-items ((tl traffic-lights) val)
  (set-program tl NIL)
  (reset tl)
  (call-next-method))

(defmethod assert-lights ((tl traffic-lights))
  (when (program tl)

;    (format T "hoj~%")

    (mapcar (lambda (l v)
              (set-onp l v))

            (lights tl)
            (nth (position-in-program tl)
                 (program tl)))))
    


(defun make-point (x y)
  (set-y (set-x (make-instance 'point) x) y))

(defun make-poly (list-of-points)
  (set-items (make-instance 'polygon)
             (mapcar
              #'make-point
              (mapcar #'car list-of-points)
              (mapcar #'cadr list-of-points))))

(defun make-light (x y color)
  (set-color-on
   (move (make-instance 'light) x y)
   color))

(defun make-traffic-lights ()
  (set-items 

   (make-instance 'traffic-lights)



   (list

    (make-light 0 -20 :red)
    (make-light 0   0 :orange)
    (make-light 0  20 :green)

    ;podklad
    (set-color 
     (set-filledp 
      (make-poly '((-10  30)
                   ( 10  30)
                   ( 10 -30)
                   (-10 -30))) T)
     :black))))
    
  

(defun demo ()
  (let ((tl (move (make-traffic-lights) 50 50))
        (win (make-instance 'window)))
    
    (set-program tl '((T NIL NIL)
                      (T T NIL)
                      (NIL NIL T)
                      (NIL T NIL)))

  (set-shape win tl)

  (sleep .001)
  (dotimes (i 100)
    (redraw win)
    (next-position tl)
    (sleep 1))))