;;; -*- Mode:LISP; Package:(INVENTS USE (LISP GLOBAL OBJ)); Readtable:CL; Base:10 -*-

(if (not(find-package 'invents))
    (make-package 'invents
		  :use '("LISP" "GLOBAL" "OBJ")))

(in-package 'invents)

(provide 'inventory)

;;;

(defparameter *verbose* nil)

(defmacro verbose(fmt &body body)
  `(when *verbose*
     (format t "~%+++ ")
     (format t ,fmt  . ,body)))
  
;;; Global object is not an inventory item object

(defobfun inventory-item-p (&optional obj)
  (cond
    ((null obj) nil)
    ((typep obj 'obj:obj) (ask obj (inventory-item-p)))))

;;; Lots

(defstruct (lot (:type :list)
		(:constructor
		  create-lot
		  (qty &optional
		       (material-cost 0.0)
		       (labor-cost 0.0)
		       (other-cost 0.0)
		       &aux
		       (total-cost
			 (float (+ material-cost
				   labor-cost
				   other-cost))))))
  (qty 0.0 :type :number)
  (material-cost 0.0 :type :number)
  (labor-cost 0.0 :type :number)
  (other-cost 0.0 :type :number)
  (total-cost 0.0 :type :number))

(defun print-lot(lot)
  (format t "~&~{~4d @ (material ~,,5$ / labor ~,,5$) + other ~,,5$) = ~,,9$$~}"
	  lot))

(defun lot-cost(lot)
  (setf (lot-total-cost lot)
	(+ (lot-material lot)
	   (lot-labor lot)
	   (lot-other lot))))
    
(defun lots-total-qty(lots)
  (apply #'+ (mapcar #'lot-qty lots)))

(defun lots-total-material(lots)
  (apply #'+ (mapcar #'lot-material-cost lots)))

(defun lots-total-material(lots)
  (apply #'+ (mapcar #'lot-material-cost lots)))

(defun lots-total-other(lots)
  (apply #'+ (mapcar #'lot-other-cost lots)))
 
(defun lots-total-cost(lots)
   (apply #'+ (mapcar #'lot-total-cost lots)))

(defun combine-lot-costs(lot1 lot2)
  (if (neq (lot-qty lot1) (lot-qty lot2))
      (ferror nil "Cannot combine lot costs with unequal quantities: ~s ~s"
	      lot1 lot2))
  (create-lot (lot-qty lot1)
	      (+ (lot-material-cost lot1) (lot-material-cost lot2))
	      (+ (lot-labor-cost lot1) (lot-labor-cost lot2))
	      (+ (lot-other-cost lot1) (lot-other-cost lot2))))

(defun reduced-lot(reduce-qty lot)
  (when (>= (lot-qty lot) reduce-qty)
    (let((newlot (copy-list lot)))
      (setf (lot-qty newlot) (- (lot-qty lot) reduce-qty))
      newlot)))

(defun remove-qty-from-lots(need got lots)
  (let*((lot (car lots))
	(qty (lot-qty lot)))
    (cond
      ((null lot) nil)
      ((< need qty)
       (values (append got
		       (ncons (reduced-lot (- qty need) lot)))
	       (append (ncons (reduced-lot need lot))
		       (cdr lots))))
      ((> need qty)
       (remove-qty-from-lots
	 (- need qty)
	 (append got (ncons lot))
	 (cdr lots)))
      (t					; (= need qty)
       (values (append got (ncons lot))
	       (cdr lots))))))

;;; INVENTORY LISTS

(makunbound 'inventory-item)

(defkind inventory-item)

(definstancevars inventory-item
 ;;;descriptive vars
  (name nil)					;item symbol name
  (description "???")				;descriptive string name
  (class 'generic)				;item is in class...
  (partnum 'n/a)				;part number
 ;;;unit costing components
  (material-unit-cost 0.0)			;unit cost of materials
  (labor-unit-cost 0.0)				;unit cost of labor
  (other-unit-cost 0.0)				;unit miscellaneous other costs
  (default-unit-cost 0.0)				;default unit cost
 ;;;accumulated cost totals
  (total-material-cost 0.0)
  (total-labor-cost 0.0)
  (total-other-cost 0.0)
  (total-cost 0.0)				;accumulated cost of goods
 ;;;quantities
  (quantity 0)					;computed quantity on hand
  (keep-at-least 10)				;minimum amount to keep on hand
  (order-mode 'fifo)				;removal mode -- 'FIFO (first-in/first-out) or 'LIFO
  (lots nil)					;qty/cost list for calculations and removal
  (transfers-out nil)				;where removed items went
  )

;;; An inventory item object *is* an inventory item object *is* an ...

(defobfun (inventory-item-p inventory-item) (&rest ignore)  t)

;;; Be sure to keep total variables up-to-date

(defobfun (update-cost inventory-item)()
  (have 'total-material-cost 0.0)
  (have 'total-labor-cost 0.0)
  (have 'total-other-cost 0.0)
  (have 'total-cost 0.0)
  (loop for lot in lots
	as material = (lot-material-cost lot)
	as labor = (lot-material-cost lot)
	as other = (lot-material-cost lot)
	as total = (lot-total-cost lot)
	do
	(incf total-material-cost material)
	(incf total-labor-cost labor)
	(incf total-other-cost other)
	(incf total-cost total))
  total-cost)

(defobfun (update-default-unit-cost inventory-item)()
  (have 'default-unit-cost
	(+ material-unit-cost labor-unit-cost other-unit-cost))
  default-unit-cost)

(defobfun (update-on-hand inventory-item)()
  (have 'quantity (lots-total-qty lots))
  quantity)

(defobfun (warn-on-shortage inventory-item)()
  (if (< quantity keep-at-least)
      (verbose "Down to ~d of ~a on-hand, should be ~d"
	quantity obj-name keep-at-least)))

;;; Call (update-inventory) to keep them all straight

(defobfun (update-inventory inventory-item)()
  (update-cost)
  (update-default-unit-cost)
  (update-on-hand))

#| Handy exist function for an INVENTORY-ITEM.  Call like:

  (oneof inventory-item 'WIDGETS "Widget Devices"
     '$class 'things
     '$material 15.0 '$labor 2.75 '$other	;for default unit costs
     '$keep 300
     '$partnum '3243-0000)				;minimum number to keep around
|#

(defobfun (exist inventory-item)
	  (item-name item-description
		     &rest args
		     &key*  $class $partnum
		     $material $labor $other
		     $keep)
  (apply #'shadowed-exist args)
  (have 'name item-name)
  (have 'obj-name (string-append "Inventory Item " name))
  (have 'description item-description)
  (if $class (have 'class $class))
  (if $partnum (have 'partnum $partnum))
  (if $material (have 'material-unit-cost (float $material)))
  (if $labor (have 'labor-unit-cost (float $labor)))
  (if $other (have 'other-unit-cost (float $other)))
  (if $keep (have 'keep-at-least (float $keep)))
  (update-inventory))

(defobfun (make-inventory-lot inventory-item)
	  (qty
	    &optional
	    (material material-unit-cost)
	    (labor labor-unit-cost)
	    (other other-unit-cost))
  (create-lot qty
	      (* (float material) qty)
	      (* (float labor) qty)
	      (float other)))

(defobfun (add-lot inventory-item) (lot)
  (have 'lots
	(if (eq order-mode 'lifo)
	    (cons lot lots)
	    (reverse (cons lot (reverse lots)))))
  (update-inventory))

(defobfun (remove-qty inventory-item)(need)
  (multiple-value-bind(removed remains)
      (remove-qty-from-lots need nil lots)
    (cond
      (removed
       (setq lots remains)
       removed)
      (t (format t "~&???Can't remove ~d ~a, only ~d on-hand"
		 need name (update-on-hand))))))

(defobfun (transfer-qty inventory-item) (qty to)
  (let((safe-lots lots)
       removed unsafe-flag)
    (unwind-protect
	(progn
	  (setq removed
		(setq unsafe-flag (remove-qty qty)))
	  (when removed
	    (push (append removed (ncons to))
		  transfers-out)
	    (dolist (lot removed)
	      (ask to (add-lot
			(combine-lot-costs
			  (make-inventory-lot (lot-qty lot))
			  lot))))
	    (update-inventory)
	    (warn-on-shortage))
	  (setq unsafe-flag nil))
      (when unsafe-flag
	(have 'lots safe-lots)))
    removed))


;;; Reporting functions

(defobfun (list-inventory inventory-item)()
  (update-inventory)
  (format t "~&~a [~a] is a ~a :"
	  name description class)
  (format t "~&~3tOrder is ~a" order-mode)
  (when lots
      (format t "~&~3tMaterial lots:  ~~a~~%"
	      (with-output-to-string (standard-output)
		(dolist (lot lots)
		  (print-lot lot))))
      (format t "~&~3tTotal qty/cost: ~4d~,5t$~,,9$" quantity total-cost))
  (format t "~2&~a ~d~%"
	  (if (< quantity keep-at-least)
	      "!!! Short by"
	      "... Cushion:")
	  (abs (- keep-at-least quantity))))

(defun line-item(desc class qty cost)
  (declare(special desc-cols class-cols qty-cols cost-cols))
  (flet
    ((rightfmt (item &optional (fmt :decimal))
	     (cond
	       ((numberp item)
		(if (equal fmt :decimal) " ~vd " "$~2,,v$ "))
	       ((characterp item)
		(if(char-equal item #\-)
		   " ~v,,,'-a "
		   " ~va "))
	       (t " ~va "))))
    (let((fmt (string-append "~&"
			     (rightfmt desc)
			     (rightfmt class)
			     (rightfmt qty)
			     "~5@t"
			     (rightfmt cost :dollars))))
      (format t fmt
	    desc-cols desc
	    class-cols class
	    qty-cols qty
	    cost-cols cost))))

(defobfun (table-inventory inventory-item)
	  (&optional (desc-cols 25)
		     (class-cols 15)
		     (qty-cols 8)
		     (cost-cols 8))
  (declare(special desc-cols class-cols qty-cols cost-cols))
  (update-inventory)
  (let*((desc (if (> desc-cols (+ 2 (string-length description)))
		 description
		 (substring description 0 (- desc-cols 2))))
	(bdesc (format nil "[~a]" desc)))
    (line-item bdesc class quantity total-cost)))
;    (format t "~&[~va] ~va ~vd~v@t$~2,,v$"
;	    (- desc-cols 2) desc
;	    class-cols class
;	    qty-cols quantity
;	    5 cost-cols total-cost)))

;;; Inventory Lists
  
(makunbound 'inventory-list)

(defkind inventory-list)

(definstancevars inventory-list
  (items nil)
  (item-classes)
  (total-cost))

(defobfun (exist inventory-list)
	  (&rest args
		 &key* $includes)
  (apply #'shadowed-exist args)
  (dolist (item $includes)
    (new-item item))
  (update-cost))

(defobfun (inventory-item-p inventory-list) (&rest ignore)  t)
  
(defobfun (item-names inventory-list) ()
  (mapcar #'(lambda(obj) (ask obj name)) items))

(defobfun (new-item inventory-list) (item-obj)
  (if (not (or (ask item-obj (inventory-item-p))
	       (ask item-obj (inventory-list-p))))
      (ferror nil "~s is not an INVENTORY object"
	      item-obj))
  (have 'items (append items (ncons item-obj)))
  (pushnew (ask item-obj class) item-classes))

(defobfun (kill-item inventory-list) (item-name)
  (have 'items
	(remove item-name items
		:key #'(lambda(obj)(ask obj name))
		:test #'string-equal))
  items)

(defobfun (find-item inventory-list) (finditem)
  (loop for item in items
	with lookfor = (ask finditem name)
	when (string-equal (ask item name) lookfor)
	return item))

(defobfun (update-cost inventory-list) ()
  (have 'total-cost
	(apply #'+ (mapcar #'(lambda(obj)
			       (ask obj (update-cost))) items)))
  total-cost)

(defobfun (transfer-qty inventory-list) (qty from to)
 (ask from (transfer-qty qty to)))


(defobfun (list-inventory inventory-list)()
  (let((itemno 0))
    (dolist (item items)
      (incf itemno)
      (format t "~%~d. ~~a~"
	      itemno
	      (with-output-to-string(standard-output)
		(ask item (list-inventory)))))))

(defobfun (table-inventory inventory-list)
	  (&optional (desc-cols 25)
		     (class-cols 15)
		     (qty-cols 8)
		     (cost-cols 9))
  (declare(special desc-cols class-cols qty-cols cost-cols))
  (if (null items)
      (format t "~&No items recorded in list.")
      (let((item-cols 3)
	   (itemno 0))
	(format t "~%~vt  ~~a~"
		item-cols
		(with-output-to-string(standard-output)
		  (line-item "ITEM" "CLASS"
			     "QUANTITY" "COST")
		  (line-item #\- #\- #\- #\-)))
	(dolist (item items)
	  (incf itemno)
	  (format t "~%~vd. ~~a~"
		  item-cols itemno
		  (with-output-to-string(standard-output)
		    (ask item (table-inventory desc-cols class-cols qty-cols cost-cols)))))
	(format t "~%~vt  ~~a~"
		item-cols
		(with-output-to-string(standard-output)
		  (line-item "" "" "" #\-)
		  (line-item "" "" "" (update-cost)))))))


;(defobfun (table-inventory inventory-list)
;	  (&optional (desc-cols 25)
;		     (class-cols 15)
;		     (qty-cols 8)
;		     (cost-cols 9))
;  (if (null items)
;      (format t "~&No items recorded in list.")
;      (let((item-cols 3)
;	   (itemno 0))
;	(format t "~2%~v@t  ~va ~va ~v@a~5@t ~v@a"
;		item-cols desc-cols "ITEM"
;		class-cols "CLASS"
;		qty-cols "QUANTITY"
;		cost-cols "COST")
;	(format t "~&~v@t  ~v,,,'-a ~v,,,'-a ~v,,,'-a~5@t ~v,,,'-a"
;		item-cols desc-cols ""
;		class-cols ""
;		qty-cols ""
;		cost-cols "")
;	(dolist (item items)
;	  (incf itemno)
;	  (format t "~%~vd. ~~a~"
;		  item-cols itemno
;		  (with-output-to-string(standard-output)
;		    (ask item (table-inventory desc-cols class-cols qty-cols cost-cols)))))
;	(format t "~2%~v@t  ~va ~va ~va~5@t ~v,,,'-a"
;		item-cols desc-cols ""
;		class-cols ""
;		qty-cols ""
;		cost-cols "")
;	(format t "~&~v@t  ~va ~va ~va~5@t$~2,,v,'$$"
;		item-cols desc-cols ""
;		class-cols ""
;		qty-cols ""
;		cost-cols (update-cost))
;	)))

;;; Assemblies

(makunbound 'assembly)

(defkind assembly inventory-list inventory-item)

(defobfun (exist assembly)
	  (name description &rest args)
  (apply #'shadowed-exist name description args)
  (have 'obj-name (format nil "~:(~a~) ~a" class-name name))
  (update-cost))

(defobfun (table-inventory assembly) (&rest args)
  (format t "~%[~a]:~&" obj-name)
  (format t "~5t~~a~"
	  (with-output-to-string(standard-output)
	    (apply #'shadowed-table-inventory args))))

;;; Purchase items

(defkind purchase-item assembly)

(definstancevars purchase-item
  (price 0.0))

(defobfun (exist purchase-item)
	  (&rest args
		 &key* $price)
  (apply #'shadowed-exist args)
  (if $price (have 'price $price)))

;;; Price lists

(defkind price-list assembly)

;;; Customer orders

(defkind customer-order price-list)

(definstancevars customer-order
  (customer-name "CUSTOMER")
  (sales-order nil)
  (shipping-cost 0.0)
  (profit 0.0))

(defobfun (exist customer-order)
	  (&rest args
		 &key* $customer $quantities)
  (apply #'shadowed-exist args)
  (if $customer (have 'customer-name $customer))
  (if $quantities
      (loop for qlist in $quantities
	    as item = (find-item (car qlist))
	    do (ask item (have 'lots (ncons(ncons (cadr qlist))))))))

(defobfun (update-profit customer-order) ()
  (have 'profit (- price (update-cost)))
  profit)



;;; Handy macros for user

(defmacro define-item (item-name description
		       &rest args)
  (declare(zwei:indentation 1 1 2 3))
  `(eval-when (eval compile load)
     (makunbound ',item-name)
     (defparameter
       ,item-name
       (oneof inventory-item
	      ',item-name ,description
	      ,@args))))

(defmacro define-inventory (name &rest items)
  (declare(zwei:indentation 1 0))
  `(eval-when (compile load)
     (makunbound ',name)
     (defparameter
       ,name
       (oneof inventory-list
	      '$includes
	      (list ,@items)))))

(defmacro define-assembly (name description &rest items)
  (declare(zwei:indentation 1 1 2 3))
  `(eval-when (compile load)
     (makunbound ',name)
     (defparameter
       ,name
       (oneof assembly
	      ',name ',description
	      '$includes
	      (list ,@items)))))

(defmacro define-purchase-item(name description price
			       &rest assemblies)
  `(eval-when (compile load)
     (makunbound ',name)
     (defparameter
       ,name
       (let*((assys (list ,@assemblies))
	     (iteml (loop for assembly in assys
			  append (ask assembly items))))
;	 (declare(special iteml))
	 (oneof purchase-item
	      ',name ',description
	      '$price ,price
	      '$includes iteml)))))

(defmacro buy (item-name qty &rest cost-args)
  (declare(arglist item-name qty
		   material-cost labor-cost other-cost))
  `(let*((item ,item-name)
	 (newlot (ask item (make-inventory-lot
			     ,qty ,@cost-args))))
     (declare(special newlot))
     (ask item (add-lot newlot))
     (verbose "Added ~d of ~a @ ~s"
       ,qty (ask item obj-name) (lot-total-cost newlot))))

(defmacro get-free(item qty)
  `(buy ,item ,qty 0.0 0.0 0.0))

(defmacro transfer (qty from to)
  `(ask ,from (transfer-qty
		,qty ,to)))

(defun have-enough2 (qty &rest items)
  (cond
    ((null items) t)
    ((<= qty (ask (car items) quantity))
     (apply #'have-enough qty (cdr items)))
    (t (values nil (car items)))))

(defun have-enough (qty &rest items)
  (apply #'have-enough2 qty (remove-duplicates items)))

(defmacro build(qty to &rest from)
  `(let((qty ,qty)
	(to ,to)
	(from (list ,@from)))
     (declare(special qty to))
     (multiple-value-bind(enough ofwhat)
	 (apply #'have-enough qty from)
       (if (not enough)
	   (ferror nil "Not enough of ~s to build ~s"
		   (ask ofwhat obj-name)
		   (ask to obj-name) )))

     (dolist(item from)
       (transfer qty item to))
     (verbose "Built ~d ~a from ~a"
       qty
       (ask to obj-name)
       (loop for item in from
	     collect (ask item obj-name)))
     (ask to quantity)))

;(defmacro ship (qty item &optional (shipcost 10.0))
;  `(let((newitem (ask shipped (find-item ,item)))
;       (costx (or ,shipcost (ask ,item shipping-cost))))
;     (declare(special newitem costx))
;    (unless newitem
;      (setq newitem (make-obj ,item))
;      (ask newitem (have 'lots nil)))
;    (ask shipped (new-item newitem))
;    (transfer ,qty ,item newitem costx)))

;;; Cost accounting