#lang scheme

;;Agentes
(define ag-evaluar-peticiones
  (lambda (orden1 orden2);orden1= (levantar b) orden2= (poner b cesto/c)
    (let ((ord1 (car orden1))
          (bloq1 (cadr orden1))
          (bloq2 (caddr orden2))
          )
      (if (is-a? bloq2 triangulo%)
          (printf 
           "No puedo poner ~a encima de ~a~n" 
           (send bloq1 get-label) (send bloq2 get-label))
          (ag-calc-coord bloq1 bloq2))
      ) ))
    
(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)
           )
      (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)
      )
    ) )

;;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 (cadddr coors))
          (y-reub (car (cddddr coors)))
          )
    (ag-motor-brazo-contacto bloque x-pos-bloque y-pos-bloque)
    (ag-motor-levantar bloque x-pos-bloque x-linea-brazo)
    (ag-motor-trasladar bloque x-reub y-reub)
    (ag-motor-reset-brazo) ) ))

(define ag-orden-motora
  (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))
           )
      (ag-motor-brazo-contacto bloque x-pos-bloque y-pos-bloque)
      (ag-motor-levantar bloque x-pos-bloque x-linea-brazo)
      (if (equal? lugar 'cesto)
          (let* ((cesto-disp (send cesto get-disp))
                 (ancho-bloq (send bloque get-ancho))
                 (x-reub (+ (/ ancho-bloq 2) cesto-disp))
                 (y-reub (cdr (send bloque get-ini)))
                 )
            (ag-motor-trasladar bloque x-reub y-reub) 
            (send cesto set-disp ancho-bloq) );;OJO no debiera estar aquí
          (let* ((alto-bloque (send bloque get-alto))
                 (pos-lugar (send lugar get-pos))
                 (x-reub (car pos-lugar))
                 (y-reub (- (cdr pos-lugar) alto-bloque))
                 )
            (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 2)
      ))

(define ag-motor-levantar
  (lambda (bloque x y)
    (ubicar dc 
            (list bloque x y) 
            (list brazo x y))
    (sleep/yield 2)
    ))

(define ag-motor-trasladar
  (lambda (bloque x y)
    (ubicar dc 
            (list bloque x y) 
            (list brazo x y))
  (sleep/yield 2)
  ))

(define ag-motor-reset-brazo
  (lambda ()
    (reset-ventana dc) 
    (sleep/yield 2) ))


