#lang scheme/gui

(require "Bloques-Cesto-Brazo.ss")

(define sistema%
  (class object%
    (init-field
     (interfaz #f))
    (field
     (mensaje #f)
     (respuesta #f))
;;Agentes
    (define symbol->bloque
      (lambda (symbol)
        (case symbol
          ((a) a)
          ((b) b)
          ((c) c)
          ((d) d)
          ((e) e)
          ((f) f)
          ((cesto) cesto)
          )))
    (define ag-evaluar-peticiones
      (lambda (orden1 orden2);orden1= (levantar b) orden2= (poner b cesto/c)
        (let ((ord1 (car orden1))
              (bloq1 (symbol->bloque (cadr orden1)))
              (bloq2 #f)
              )
          (if orden2
              (begin
                (set! bloq2 (symbol->bloque (caddr orden2)))
                (if (is-a? bloq2 triangulo%)
                    (printf 
                     "~nNO PUEDO PONER ~a ENCIMA DE ~a~n~n" 
                     (send bloq1 get-label) (send bloq2 get-label))
                    (ag-calc-coord bloq1 bloq2)))
              (ag-calc-coord bloq1 #f) )
          ) ))
    
    (define ag-calc-coord
      (lambda (bloque lugar)
        (let* ((x-linea-brazo 200)
               (pos-bloque (send bloque get-pos))
               (x-pos-bloque (car pos-bloque))
               (y-pos-bloque (cdr pos-bloque))
               (cesto-disp (send cesto get-disp))
               (ancho-bloq (send bloque get-ancho))
               (alto-bloque (send bloque get-alto))
               (pos-lugar #f)
               (x-reub #f)
               (y-reub #f)
               )
          (cond
            (lugar
             (if (equal? lugar cesto)
                 (begin
                   (set! x-reub (+ (/ ancho-bloq 2) cesto-disp))
                   (set! y-reub (cdr (send bloque get-ini)))
                   (send cesto set-disp ancho-bloq)
                   )
                 (begin
                   (set! pos-lugar (send lugar get-pos))
                   (set! x-reub (car pos-lugar))
                   (set! y-reub (- (cdr pos-lugar) alto-bloque)) ) )
             (ag-orden-motor 
              bloque x-pos-bloque y-pos-bloque x-linea-brazo x-reub y-reub)
             )
            (else
             (ag-orden-motor 
              bloque x-pos-bloque y-pos-bloque x-linea-brazo)) )
        ) ))
    
;;Agentes de motor
    (define ag-orden-motor
      (lambda (bloque . coors)
        (let ((x-pos-bloque (car coors))
              (y-pos-bloque (cadr coors))
              (x-linea-brazo (caddr coors))
              (x-reub #f)
              (y-reub #f)
              )
          (ag-motor-brazo-contacto bloque x-pos-bloque y-pos-bloque)
          (ag-motor-levantar bloque x-pos-bloque x-linea-brazo)
          (unless (null? (cdddr coors))
            (set! x-reub (cadddr coors))
            (set! y-reub (car (cddddr coors)))
            (ag-motor-trasladar bloque x-reub y-reub)
            (ag-motor-reset-brazo))
          ) ))
    
    (define ag-motor-brazo-contacto
      (lambda (bloque x y)
        (ubicar dc
                (list bloque x y)
                (list brazo x y))
        (sleep/yield 1)
        ))
    
    (define ag-motor-levantar
      (lambda (bloque x y)
        (ubicar dc 
                (list bloque x y) 
                (list brazo x y))
        (sleep/yield 1)
        ))
    
    (define ag-motor-trasladar
      (lambda (bloque x y)
        (ubicar dc 
                (list bloque x y) 
                (list brazo x y))
        (sleep/yield 1)
        ))
    
    (define ag-motor-reset-brazo
      (lambda ()
        (reset-ventana dc) 
        (sleep/yield 1) ))

    (define/public accion
      (lambda ()
        (let go ((mensaje (send interfaz accion)) )
          ;(printf "mensaje: ~a~n" mensaje)
          (ag-evaluar-peticiones (car mensaje) (cadr mensaje))
          (go 
           (send interfaz accion))
          ) ))
    
    (super-new) ))

(require "Interfaz.ss")

(define robot (make-object sistema% interfaz))


;(send robot accion (list 'levantar f) (list 'poner f 'cesto))
;(send robot accion (list 'levantar a) (list 'poner a 'cesto))
;(send robot accion (list 'levantar c) (list 'poner c b))
;(send robot accion (list 'levantar b) (list 'poner b c))
;(list 'levantar d) #f);FALLA AL FALTAR 2ª ORDEN
(send robot accion)
      
