; auction scanner process

(require (lib "list.ss"))
(require (file "db.ss"))
(require (file "timestamp.ss"))
(require (lib "trace.ss"))

(define sleep-interval 5) ; 300 ?
(define auctions #f)
(define expired-auctions #f)
(define ts #f)

(printf "Starting Wishforge auction scanner~n")

(define sleep-dots
  (lambda (seconds)
    (let loop ([secs seconds])
      (if (> secs 0)
        (begin
	  (printf ". ")
	  (flush-output)
	  (sleep 1)
	  (loop (sub1 secs)))
	(newline)))))

(define-struct auction
  (login symbol pledger number start end) #f)

(define parse-auction
  (lambda (auc)
    (let* ([cua (reverse auc)]
	   [ts (cadr cua)]
	   [auc-len (string->number (car cua))]
	   [end (add-days-to-timestamp ts auc-len)]
	   [new-cua (cons end (cdr cua))]
	   [new-auc (reverse new-cua)])
    (apply make-auction new-auc))))

(define expired?  ; TODO validate that these are timestamps
  (lambda (ts)
    (lambda (auc)
      (string>? ts (auction-end auc)))))

(define cmp-bids-by-amount
  (lambda (bid1 bid2)
    (let* ([get-amt (lambda (bid) (list-ref bid 4))]
	   [amt1 (get-amt bid1)]
	   [amt2 (get-amt bid2)])
      (< amt1 amt2))))

; Dutch auction model
; look at all bidders, award in descending order of bid
; all successful bidders pay the same as the lowest-bidding successful bidder 
(define get-valid-bids
  (lambda (auc)
    (let* ([login (auction-login auc)]
	   [symbol (auction-symbol auc)]
	   [pledger (auction-pledger auc)]
	   [number-to-award (auction-number auc)]
	   [bids (bids-for-auction login symbol pledger)]
	   [sorted-bids (sort bids cmp-bids-by-amount)])
      (let bid-loop ([potential-bids sorted-bids]
		     [accepted-bids null]
		     [count 0]
		     [low-bid-amount 'not-found])
	(if (or (null? potential-bids) (>= count number-to-award))
	    (values accepted-bids low-bid-amount)
	    (let* ([curr-bid (car potential-bids)]
		   [curr-bid-num (list-ref curr-bid 3)]
		   [curr-bid-amount (list-ref curr-bid 4)]
		   [new-count (+ count curr-bid-num)]
		   [awarded-amount 
		    (if (> new-count number-to-award)
			(- number-to-award count)
			curr-bid-num)]
                   [new-low-bid-amount 
		    (if (or (symbol? low-bid-amount)
			    (< curr-bid-amount low-bid-amount))
			curr-bid-amount
			low-bid-amount)]
                   [accepted-bid ; replace number_pledges
		    (match curr-bid
			   ((login bidtime symbol _ _ bidder pledger award-time seller)
			    (list login bidtime symbol awarded-amount
				  'use-low-bid-amount bidder pledger award-time seller)))])
	      (bid-loop
	       (cdr potential-bids)
	       (cons accepted-bid accepted-bids)
	       new-count
	       new-low-bid-amount)))))))

(define change-bid-price
  (lambda (price)
    (lambda (bid)
      (match bid
        ((     login bidtime symbol number_pledges _     bidder pledger award-time seller)
	 (list login bidtime symbol number_pledges price bidder pledger award-time seller))))))

(let loop ()
  (set! ts (get-timestamp))
  (set! auctions (map parse-auction (get-all-auctions)))
  (set! expired-auctions (filter (expired? ts) auctions))
  (printf "auctions: ~a~n" auctions)
  (printf "expired auctions: ~a~n" expired-auctions)
  (for-each 
   (lambda (a)
     (call-with-values 
	 (lambda () (get-valid-bids a))
       (lambda (accepted-bids lo)
	 (printf "accepted: ~a  lo: ~a~n" accepted-bids lo)
	 (let ([bids/lo-price
		(map (change-bid-price lo) accepted-bids)])
	   (award-bids bids/lo-price)))))
   expired-auctions)
  ;; TODO -- process each accepted bid
  ; change "awarded" field in bids, delete?
  ; add entries to held_pledges, may be several
  ; remove entry for seller in held_pledges, perhaps not all sold
  ; delete auction entry?  in production system, wouldn't want to clog up table
  ; delete all bids for this auction?
  (printf "Pausing ~a seconds~n" sleep-interval)
  (sleep-dots sleep-interval)
  (loop))