;;;; -*- mode:emacs-lisp;coding:utf-8 -*- ;;;;****************************************************************************** ;;;;FILE: pjb-bourse.el ;;;;LANGUAGE: emacs lisp ;;;;SYSTEM: emacs ;;;;USER-INTERFACE: emacs ;;;;DESCRIPTION ;;;; ;;;; This module exports ;;;; ;;;;AUTHORS ;;;; Pascal J. Bourguignon ;;;;MODIFICATIONS ;;;; 199?/??/?? Creation. ;;;;BUGS ;;;;LEGAL ;;;; LGPL ;;;; ;;;; Copyright Pascal J. Bourguignon 1990 - 2011 ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 2 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;;; ;;;;****************************************************************************** (require 'pjb-cl) (require 'pjb-list) (require 'pjb-utilities) (require 'pjb-euro) (require 'pjb-strings) (require 'pjb-object) (provide 'pjb-bourse) (defun debug-tag () nil) (defun percent (num denum) (if (or (null denum) (= denum 0.0)) 0.0 (* 100.0 (/ num (+ 0.0 denum))))) (defun class-attributes (c) (aref (get c 'eieio-class-definition) class-public-a)) ;;------------------------------------------------------------------------------ ;; ;; +-----------+ +-----------+ +----------------+ ;; | Portfolio |---------------| Line |---------------| Position | ;; +-----------+ 0,1 0,n +-----------+ 0,1 0,n +----------------+ ;; | | symbol | | buy-quantity | ;; | | devise | | sell-quantity | ;; | +-----------+ | buy-amount | ;; | | sell-ammount | ;; | | comissions | ;; | | nb-operations | ;; | n | open-date | ;; +----------------+ +---------------+ | last-date | ;; | DeviseAccount | | BuySellOp | | /state | ;; +----------------+ +---------------+ +----------------+ ;; | ;; / \ ;; +------+---+------+ ;; | | ;; +----------+ +-----------+ ;; | BuyOp | | SellOp | ;; +----------+ +-----------+ ;; ;;------------------------------------------------------------------------------ ;; ;; ;; +-------------------------------------------+ ;; | Position | ;; +-------------------------------------------+ ;; | buy-amount | ;; | buy-quantity | ;; | sell-ammount | ;; | sell-quantity | ;; | comissions | ;; | nb-operations | ;; | open-date | ;; | last-date | ;; +-------------------------------------------+ ;; | state | ;; | is-closed | ;; | is-running | ;; | update-with-operation(operation) | ;; | amount-invested | ;; | quantity | ;; | gain | ;; | paid-per-share | ;; | owner-line | ;; +-------------------------------------------+ ;; 1,n | positions {ordered} ;; | ;; | ;; | ;; | ;; 0,1 | owner-line ;; +-------------------------------------------+ ;; | Line | ;; +-------------------------------------------+ ;; | symbol | ;; | devise | ;; +-------------------------------------------+ ;; | buy-amount --> | ;; | buy-quantity --> | ;; | sell-amount --> | ;; | sell-quantity --> | ;; | comission --> | ;; | nb-operations --> | ;; | | ;; | amount-invested --> | ;; | quantity --> | ;; | gain --> | ;; | paid-per-share --> | ;; | | ;; | last-position | ;; | open-new-position | ;; | | ;; | average-comission | ;; | total-buy-amount | ;; | total-gain | ;; | update-with-operation | ;; +-------------------------------------------+ ;; 1,1 [ symbol ] lines ;; | ;; | ;; | ;; | ;; 0,1 | ;; +-------------------------------------------+ ;; | Portfolio | ;; +-------------------------------------------+ ;; | operations | ;; | lines | ;; | total-credit | ;; | total-debit | ;; | total-comissions | ;; | total-operations | ;; +-------------------------------------------+ ;; | add-line(line) | ;; | add-operation(operation) | ;; | line-with-symbol(symbol) | ;; | sort-portfolio-lines | ;; | total-liquidite | ;; | total-opcom | ;; +-------------------------------------------+ ;;;--------------------------------------------------------------------- ;;;--- DeviseAccount --------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass DeviseAccount (PjbObject) ((amounts :initform nil :accessor amounts :type list :documentation "The alist where the (devise . amount) are stored.")) (:documentation "A DeviseAccount is an account where the amount is stored separately for each devise [See: pjb-euro].")) (defmethod* amount-at-devise ((self DeviseAccount) devise) "Retourne le montant de la devise indiquée dans le devise-account. Voir account-valuation pour la valeur totale du devise-account." (cdr (assoc devise (amounts self)))) (defmethod* devises ((self DeviseAccount)) "Retourne la liste des devises dans le compte." (mapcar 'car (amounts self))) (defmethod* account-valuation ((self DeviseAccount) devise) "Retourne la valeur du devise-account dans la devise indiquée. Utilise pjb-euro, et nécessite pour les devises flottantes, des cours à jour." (let ((total-euro 0.0)) (mapc (lambda (a) (setq total-euro (+ total-euro (euro-from-value (cdr a) (car a))))) (amounts self)) (euro-to-value devise total-euro))) (defmethod* account-add ((self DeviseAccount) devise montant) "Additionne au devise-account le montant indiqué dans la devise indiquée. Pour additionner deux comptes, utiliser account-add-account. Return: self." (let ((ligne (assoc devise (amounts self)))) (if ligne (setcdr ligne (+ (cdr ligne) montant)) (setf (slot-value self 'amounts) (cons (cons devise montant) (amounts self))))) self) (defmethod* account-sub ((self DeviseAccount) devise montant) "Soustrait du devise-account le montant indiqué dans la devise indiquée. Pour soustraire deux comptes, utiliser account-sub-account. Return: self." (let ((ligne (assoc devise (amounts self)))) (if ligne (setcdr ligne (- (cdr ligne) montant)) (setf (slot-value self 'amounts) (cons (cons devise (- 0 montant)) (amounts self))))) self) (defmethod* account-mul ((self DeviseAccount) facteur) "Multiplie le devise-account par le facteur. RETURN: self" (mapc (lambda (devise-amount) (setcdr devise-amount (* (cdr devise-amount) facteur))) (amounts self)) self) (defun compare-sequal-sn-c (a b) "Interne DeviseAccount." (string-equal (symbol-name (car a)) (symbol-name (car b)))) (defun compare-slessp-sn-c (a b) "Interne DeviseAccount." (string-lessp (symbol-name (car a)) (symbol-name (car b)))) (defun compare-slessp-sn (a b) "Interne DeviseAccount." (string-lessp (symbol-name a) (symbol-name b))) (defmethod* sorted-accounts ((self DeviseAccount)) "Returns a list of assoc (devise . amount) sorted on the devise." (sort (copy-sequence (slot-value self 'amounts)) 'compare-slessp-sn-c)) (defmethod* account-operation-account ((self DeviseAccount) (other DeviseAccount) op-lambda) "Retourne un devise-account résultat de l'opération op-lambda sur les paires de montants de même devise, et ajoute les montants-devise restants." (let ((sort-a (sorted-accounts self)) (sort-b (sorted-accounts other)) (result nil) (oresult (make-instance DeviseAccount))) (while (or sort-a sort-b) (let ((a (car sort-a)) (b (car sort-b))) (setq result (cons (cond ((and a b (compare-sequal-sn-c a b)) ;; les deux sont égaux (setq sort-a (cdr sort-a) ;; on les passe sort-b (cdr sort-b)) ;; resultat : l'operation appliquee sur eux. (cons (car a) (funcall op-lambda (cdr a) (cdr b)))) ((or (null b) (compare-slessp-sn-c a b)) ;; lequel est le plus petit ? (setq sort-a (cdr sort-a)) ;; on le passe. ;; resultat : l'operation appliquee sur lui. (cons (car a) (funcall op-lambda (cdr a) 0.0))) (t ;; lequel reste ? (setq sort-b (cdr sort-b)) ;; on le passe. ;; resultat : l'operation appliquee sur lui. (cons (car b) (funcall op-lambda 0.0 (cdr b))))) result)))) (setf (slot-value oresult 'amounts) result) oresult)) (defmethod* account-add-account ((self DeviseAccount) (other DeviseAccount)) "Additionne les deux comptes-devises." (account-operation-account self other '+)) (defmethod* account-sub-account ((self DeviseAccount) (other DeviseAccount)) "Soustrait le devise-account compte-b du devise-account compte-a." (account-operation-account self other '-)) ;;;END DeviseAccount --------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- Operation ------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass Operation (PjbObject) ((date :initform nil :initarg :date :accessor date :type symbol :documentation "Date of the Operation. This is a symbol with the format: YYYY-MM-DD.") (symbol :initform nil :initarg :symbol :accessor symbol :type symbol :documentation "The ticker symbol of the shares handled in this operation.")) (:documentation " Reification of a single operation. This is an abstract class. Concrete subclasses may be buy or sell operations or split operations. Instances of theses subclasses are made by make-operation. ")) ;; ---------- --- ---------- ---- -------- ------ ------ ------------ ;; DATE DEV MONTANT QUTE COURS FRAIS FRAIS% SYMBOL ;; YYYY-MM-DD --ERROR: OPERATION CLASS CANNOT DISPLAY-- SSSSSSSSSSSS ;; YYYY-MM-DD DEV 0000000.00 0000 00000.00 000.00 00.00% SSSSSSSSSSSS ;; YYYY-MM-DD SPLIT 0000 NEW SHARES FOR 0000 OLD SHARES SSSSSSSSSSSS (defconstant operation-format-bad "%-10s --ERROR: OPERATION CLASS CANNOT DISPLAY-- %s" "Format to print an abstract operation.") (defconstant operation-format-buy-sell "%-10s %-3s %10.2f %4d %8.2f %6.2f %5.2f%% %s" "Format to print a buy or sell operation.") (defconstant operation-format-split "%-10s SPLIT %4d NEW SHARES FOR %4d OLD SHARES %s" "Format to print a split operation.") (defmethod* as-string ((self Operation)) "RETURN: A human readable string representing the operation." (format operation-format-bad (date self) (symbol self))) ;;;END Operation ------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- Position -------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass Position (PjbObject) ((buy-quantity :initform 0 :initarg :buy-quantity :accessor buy-quantity :type number :documentation "Total number of share bought. buy-quantity>=0.") (buy-amount :initform 0.0 :initarg :buy-amount :accessor buy-amount :type number :documentation "Total amount paid. This includes the comission paid for the buys. (Expressed in the devise of the line).") (sell-quantity :initform 0 :initarg :sell-quantity :accessor sell-quantity :type number :documentation "Total number of share sold. sell-quantity>=0.") (sell-amount :initform 0.0 :initarg :sell-amount :accessor sell-amount :type number :documentation "Total amount received for sells. This includes the deducted comission paid for the sells. (Expressed in the devise of the line).") (comission :initform 0.0 :initarg :comission :accessor comission :type number :documentation "Total comissions paid. (Expressed in the devise of the line).") (nb-operations :initform 0 :initarg :nb-operations :accessor nb-operations :type number :documentation "Number of operations done.") (open-date :initform '0000-00-00 :initarg :open-date :accessor open-date :type symbol :documentation "Date of the first operation.") (last-date :initform '0000-00-00 :initarg :last-date :accessor last-date :type symbol :documentation "Date of the last operation.") (owner-line :initform nil :initarg :owner-line :accessor owner-line :documentation "The Line instance that owns this position.")) (:documentation " Reification of a position. This is the summary of a range of operations where the number of posseded shares only comes to 0 when the position is closed. A Line posses several successive Position instances, of which all but the last must be closed. ")) (defmethod* apply-to-position ((self Operation) (position Position)) "NOTE: This method must be overriden by subclasses. PRE: (equal (symbol self) (symbol (owner-line position))) DO: Apply self operation onto the position." (error "Method apply-to-line must be overriden by subclasses.")) (defmethod* as-string ((self Position)) "RETURN: a human readable string describing the position." ;; (insert (apply 'concat ;; (mapcar (lambda (x) (format "(format \" %-20s=%%S\\n\" (%s self))\n" ;; (symbol-name x) (symbol-name x))) ;; (class-attributes Position)))) (concat "Position {\n" (format " buy-quantity =%S\n" (buy-quantity self)) (format " buy-amount =%S\n" (buy-amount self)) (format " sell-quantity =%S\n" (sell-quantity self)) (format " sell-amount =%S\n" (sell-amount self)) (format " comission =%S\n" (comission self)) (format " nb-operations =%S\n" (nb-operations self)) ;; (format " open-date =%S\n" (open-date self)) ;; (format " last-date =%S\n" (last-date self)) ;; (format " owner-line =%S\n" (owner-line self)) "}\n")) (defmethod* state ((self Position)) "RETURN: the state of the Position. Either: 'newborn when no operation has been included; 'running when operations have been included, but (quantity self) never has been 0; 'closed once (quantity self) reach 0." (cond ((= 0 (nb-operations self)) 'newborn) ((= 0 (quantity self)) 'closed) (t 'running))) (defmethod* is-closed ((self Position)) "RETURN: Whether (equal (state self) 'closed)." (equal (state self) 'closed)) (defmethod* is-running ((self Position)) "RETURN: Whether (equal (state self) 'running)." (equal (state self) 'running)) (defmethod* update-with-operation ((self Position) (operation Operation)) "PRE: (not (is-closed self)) DO: Updates this position with the given operation. RETURN: self." (if (equal 'closed (state self)) (let ((msg (format "POSITION FOR %s IS CLOSED.\n" (symbol (owner-line self))))) (printf msg) (error msg))) (if (equal (state self) 'newborn) (setf (slot-value self 'open-date) (date operation))) (setf (slot-value self 'last-date) (date operation)) (apply-to-position operation self) (setf (slot-value self 'nb-operations) (1+ (nb-operations self))) self) (defmethod* amount-invested ((self Position)) "RETURN: The amount mobilized on this position. amount-invested = (- (buy-amount self) (sell-amount self)). When is-closed, this is the lost (if positive) or the gain (if negative)." (- (buy-amount self) (sell-amount self))) (defmethod* quantity ((self Position)) "RETURN: The number of share remaining in the position. quantity = (- (buy-quantity self) (sell-quantity self))" (- (buy-quantity self) (sell-quantity self))) (defmethod* gain ((self Position)) "RETURN: The gain on this position, negative if there's a loss. This is valid only when the position is closed: is-closed => gain = (- sell-amount buy-amount) (not is-closed) => gain = 0.0" (if (is-closed self) (- (sell-amount self) (buy-amount self)) 0.0)) (defmethod* paid-per-share ((self Position)) "RETURN: The cost of the remaining shares. This is valid only when running. when the position is not running, or if the amount-invested is negative, then paid-per-share = 0.0 else paid-per-share = (/ (amount-invested self) quantity)." (if (equal 'running (state self)) (if (<= (amount-invested self) 0.0) ;; We already have a gain. 0.0 (/ (amount-invested self) (quantity self))) 0.0)) ;;;END Position -------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- SplitOp --------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass SplitOp (Operation) ( (oldQuantity :initform 0 :initarg :oldQuantity :accessor oldQuantity :type number :documentation "Number of old shares. oldQuantity>=0") (newQuantity :initform 0 :initarg :newQuantity :accessor newQuantity :type number :documentation "Number of new shares. newQuantity>=0") ) (:documentation " A split operation. This kind of operation replaces oldQuantity shares by newQuantity shares. An allocation of new (free) shares can be modelized by a split from the oldQuantity required to the newQuantity = number of new share + oldQuantity. ")) (defmethod* apply-to-position ((self SplitOp) (position Position)) "NOTE: This method must be overriden by subclasses. PRE: (equal (symbol self) (symbol (owner-line position))) DO: Apply this split operation onto the position." ;;DEBUG;; (message (format "SplitOp::apply-to-position \n split=%S \n%s" self (as-string position))) ;; TODO: This should go into a Position::split method. (setf (slot-value position 'sell-quantity) (/ (* (sell-quantity position) (newQuantity self)) (oldQuantity self))) (setf (slot-value position 'buy-quantity) (/ (* (buy-quantity position) (newQuantity self)) (oldQuantity self))) ;;DEBUG;; (message (format "%s\n" (as-string position))) ) (defmethod* as-string ((self SplitOp)) "RETURN: A human readable string representing the operation." (format operation-format-split (date self) (newQuantity self) (oldQuantity self) (symbol self))) ;;;END SplitOp --------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- BuySellOp ------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass BuySellOp (Operation) ( (quantity :initform 0 :initarg :quantity :accessor quantity :type number :documentation "Number of share bought or sold. quantity>=0") (devise :initform nil :initarg :devise :accessor devise :type symbol :documentation "The devise symbol (see package pjb-euro).") (price :initform 0.0 :initarg :price :accessor price :type number :documentation "The price for one share on this operation. The price is expressed in the devise of the operation. price>0.0") (comission :initform 0.0 :initarg :comission :accessor comission :type number :documentation "The comission value for this operation. The comission is expressed in the devise of the operation. comission>=0.0") ) (:documentation " Reification of a single buy or sell operation. This is an abstract class. Concrete subclasses are BuyOp and SellOp. Instances of theses subclasses are made by make-operation. ")) (defmethod* amount-base ((self BuySellOp)) "RETURN: The total amount of this operation, excluding the comission." (* (quantity self) (price self))) (defmethod* comission-percent ((self BuySellOp)) "RETURN: The percentage the comission represents relatively to the share value." (percent (comission self) (amount-base self))) (defmethod* amount-paid ((self BuySellOp)) "RETURN: The amount paid for the operation. Negative when it's a sell operation." (+ (* (signed-quantity self) (price self)) (comission self))) (defmethod* signed-quantity ((self BuySellOp)) "RETURN: The quantity. NOTE: Should be overriden by sell operation to return the opposite." (quantity self)) (defmethod* as-string ((self BuySellOp)) "RETURN: A human readable string representing the operation." (format operation-format-buy-sell (date self) (devise self) (amount-paid self) (signed-quantity self) (price self) (comission self) (comission-percent self) (symbol self))) ;;;END SellBuyOp ------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- BuyOp ----------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass BuyOp (BuySellOp) () (:documentation " Reification of a buy operation. ")) (defmethod* amount ((self BuySellOp)) "RETURN: The total amount aid of this operation, including the comission. For buys, it's quantity*price+comission." (+ (* (quantity self) (price self)) (comission self))) (defmethod* apply-to-position ((self BuyOp) (position Position)) "PRE: (equal (symbol self) (symbol (owner-line position))), (equal (devise self) (devise (owner-line position))) DO: Apply this buy operation onto the position." (if (not (equal (devise (owner-line position)) (devise self))) (let ((msg (format "DEVISE MISMATCH WITH LINE FOR %s: %s %s\n" (symbol self) (devise (owner-line position)) (devise self)))) (printf msg) (error msg))) ;;DEBUG;; (message (format "BuyOp::apply-to-position \n buy=%S \n%s" self (as-string position))) ;; TODO: This should go into a Position::buy method. (setf (slot-value position 'buy-quantity) (+ (buy-quantity position) (quantity self))) (setf (slot-value position 'buy-amount) (+ (buy-amount position) (amount-paid self))) (setf (slot-value position 'comission) (+ (comission position) (comission self))) ;;DEBUG;; (message (format "%s\n" (as-string position))) ) ;;;END BuyOp ----------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;;--- SellOp ---------------------------------------------------------- ;;;--------------------------------------------------------------------- (defclass SellOp (BuySellOp) () (:documentation " Reification of a sell operation. ")) (defmethod* amount ((self BuySellOp)) "RETURN: The total amount paid for this operation, including the comission. For sells, it's quantity*price-comission" (- (* (quantity self) (price self)) (comission self))) (defmethod* signed-quantity ((self SellOp)) "RETURN: The opposite of the quantity, to denote a sell." (- 0 (quantity self))) (defmethod* apply-to-position ((self SellOp) (position Position)) "PRE: (equal (symbol self) (symbol (owner-line position))), (equal (devise self) (devise (owner-line position))) DO: Apply this sell operation onto the position." (if (not (equal (devise (owner-line position)) (devise self))) (let ((msg (format "DEVISE MISMATCH WITH LINE FOR %s: %s %s\n" (symbol self) (devise (owner-line position)) (devise self)))) (printf msg) (error msg))) ;;DEBUG;; (message (format "Sell::apply-to-position \n buy=%S \n%s" self (as-string position))) ;; TODO: This should go into a Position::sell method. (setf (slot-value position 'sell-quantity) (+ (sell-quantity position) (quantity self))) (setf (slot-value position 'sell-amount) (- (sell-amount position) (amount-paid self))) ;; amount-paid < 0 == sell-amount is incremented. ;; (Note if quantity*price < commission then amount-paid > 0) (setf (slot-value position 'comission) (+ (comission position) (comission self))) ;;DEBUG;; (message (format "%s\n" (as-string position))) ) ;;;END SellOp ---------------------------------------------------------- ;;;--------------------------------------------------------------------- (defun make-operation (attributes) "RETURN: either a new BuyOp (quantity>=0) or a new SellOp (quantity<0) instance built from the given attributes." (if (eq 'SPLIT (nth 1 attributes)) (let ((date (nth 0 attributes)) (newQuantity (nth 2 attributes)) (oldQuantity (nth 3 attributes)) (symbol (nth 4 attributes))) (make-instance (class-constructor SplitOp) (format "%s-%s" symbol date) 'date date 'newQuantity newQuantity 'oldQuantity oldQuantity 'symbol symbol)) (let ((date (nth 0 attributes)) (quantity (nth 1 attributes)) (devise (nth 2 attributes)) (price (nth 3 attributes)) (comission (nth 4 attributes)) (symbol (nth 5 attributes))) (make-instance (if (< 0 quantity) (class-constructor BuyOp) (class-constructor SellOp)) (format "%s-%s" symbol date) :date date :quantity (abs quantity) :devise devise :price price :comission comission :symbol symbol)))) ;;;--------------------------------------------------------------------- ;;;--- Line ------------------------------------------------------------ ;;;--------------------------------------------------------------------- (defclass Line (PjbObject) ((symbol :initform nil :initarg :symbol :accessor symbol :type symbol :documentation "The ticker symbol of this line (stored as a lisp symbol).") (devise :initform nil :initarg :devise :accessor devise :type symbol :documentation "The devise in which the shares of this line are dealt. (See: pjb-euro).") (positions :initform nil :accessor positions :type list :documentation "The list of successive positions for this line. They're stored the last one first.")) (:documentation " Reification of a Portfolio Line, where all the operations regarding a share are accumulated. ")) (defmethod* update-with-operation ((self Line) (operation BuySellOp)) "PRE: (and (or (null (devise self)) (equal (devise self) (devise operation))) (or (null (symbol self)) (equal (symbol self) (symbol operation)))) POST: (and (equal (devise self) (devise operation)) (equal (symbol self) (symbol operation))) DO: Updates this line with the given operation. RETURN: self." (if (null (devise self)) (setf (slot-value self 'devise) (devise operation))) (if (null (symbol self)) (setf (slot-value self 'symbol) (symbol operation))) (if (not (equal (symbol self) (symbol operation))) (let ((msg (format "SYMBOL MISMATCH WITH LINE FOR %s: %s\n" (symbol self) (symbol operation)))) (printf msg) (error msg))) (if (is-closed (last-position self)) (open-new-position self)) (update-with-operation (last-position self) operation)) (defmethod* open-new-position ((self Line)) "PRE: (is-closed (last-position self)) POST: self has a new newbord position ready to be filled with operations. RETURN: self" (let ((p (car (slot-value self 'positions)))) (if (and p (not (is-closed p))) (error "The last position is not closed.")) (setf (slot-value self 'positions) (cons (make-instance Position (format "%s-%d" (symbol self) (length p)) :owner-line self) (slot-value self 'positions)))) self) (defmethod* last-position ((self Line)) "RETURN: The last position of the line." (if (null (slot-value self 'positions)) (open-new-position self)) (car (slot-value self 'positions))) ;; Last position data: (defmethod* quantity ((self Line)) "RETURN: The number of share of the last postion. (All the previous positions have a number of 0 share remaining...)." (quantity (last-position self))) (defmethod* amount-invested ((self Line)) "RETURN: The amount-invested of the last position." (if (is-running (last-position self)) (amount-invested (last-position self)) 0.0)) (defmethod* comission ((self Line)) "RETURN: The comission paid for the last position." (if (is-running (last-position self)) (comission (last-position self)) 0.0)) (defmethod* nb-operations ((self Line)) "RETURN: The number of operation of the last position. (used for average-comission)" (nb-operations (last-position self))) (defmethod* average-comission ((self Line)) "RETURN: The average comission paid for the last position." (/ (comission self) (nb-operations self))) (defmethod* paid-per-share ((self Line)) "RETURN: The price paid per share for the last position." (paid-per-share (last-position self))) (defmethod* gain ((self Line)) "RETURN: The gain of the last position." (gain (last-position self))) (defmethod* buy-amount ((self Line)) "RETURN: The buy amount of the last position of the line." (buy-amount (last-position self))) (defmethod* sell-amount ((self Line)) "RETURN: The sell amount of the last position of the line." (sell-amount (last-position self))) (defmethod* buy-quantity ((self Line)) "RETURN: The buy quantity of the last position of the line." (buy-quantity (last-position self))) (defmethod* sell-quantity ((self Line)) "RETURN: The sell quantity of the last position of the line." (sell-quantity (last-position self))) ;; Totals over closed positions: (defmethod* closed-buy-amount ((self Line)) "RETURN: The sum over closed positions of (amount-base position). (used to compute the percentage gain)." (apply '+ (mapcar (lambda (pos) (buy-amount pos)) (if (is-closed (last-position self)) (positions self) (cdr (positions self)))))) (defmethod* closed-gain ((self Line)) "RETURN: The sum over closed positions of (gain position)." (apply '+ (mapcar (lambda (pos) (gain pos)) (if (is-closed (last-position self)) (positions self) (cdr (positions self)))))) ;;;END Line ------------------------------------------------------------ ;;;--------------------------------------------------------------------- ;;------------------------------------------------------------------------ ;;--- Portfolio ---------------------------------------------------------- ;;------------------------------------------------------------------------ (defclass Portfolio (PjbObject) ((operations :initform nil :accessor operations :type list :documentation "The list of operations applied to this portfolio.") (lines :initform nil :accessor lines :type list :documentation "The alist of (symbol . Line).") ;; BuySellOp totals: ;; ----------------- ;; total-opcom total-comissions total-comissions/total-amount-base (%) ;; total-credit total-debit (total-opcom :initform (lambda () (make-instance DeviseAccount)) :accessor total-opcom :documentation "The sum over operations of (amount operation).") (total-amount-base :initform (lambda () (make-instance DeviseAccount)) :accessor total-amount-base :documentation "The sum over operations of (amount-base operation).") (total-comissions :initform (lambda () (make-instance DeviseAccount)) :accessor total-comissions :documentation "The sum over operations of (comission operation).") (total-credit :initform (lambda () (make-instance DeviseAccount)) :accessor total-credit :documentation "The sum over sell operations of (amount operation).") (total-debit :initform (lambda () (make-instance DeviseAccount)) :accessor total-debit :documentation "The sum over buy operations of (amount operation).") ;; Line row: ;; --------- ;; SYMBOL QUTE DEV PAYE FRAIS REVIENT BENEFICE BENEFI% ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^ ;; Over running position Over closed positions. ;; Line totals: ;; ------------ ;; PAYE BENEFICE BENEFI% ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^ ;; Total over running positions Total over closed pos. ;; total-invested total-closed-gains total-closed-gains/total-closedbase (%) (total-invested :initform (lambda () (make-instance DeviseAccount)) :accessor total-invested :documentation "The sum over lines of (amount-invested line).") (total-closed-gains :initform (lambda () (make-instance DeviseAccount)) :accessor total-closed-gains :documentation "The sum over lines of (closed-gain line).") (total-closed-base :initform (lambda () (make-instance DeviseAccount)) :accessor total-closed-base :documentation "The sum over lines of (closed-buy-amount line).")) (:documentation " Reification of a Portfolio. ")) (defmethod* add-operation ((self Portfolio) (op BuySellOp)) "DO: Add an operation. PRE: (date (last (operations self))) <= (date operation) to ensure that the positions in the lines are not closed unduly. POST: operation is appended to operations. RETURN: self." ;; Append the operation. (if (operations self) (nconc (operations self) op) (setf (slot-value self 'operations) (cons op nil))) ;; Update the line. (let ((line (line-with-symbol self (symbol op)))) (if (null line) (progn (setq line (make-instance Line (symbol-name (symbol op)) :symbol (symbol op) :devise (devise op))) (add-line self line))) (update-with-operation line op)) self) (defmethod* compute-operation-totals ((self Portfolio)) "DO: compute the following totals from the operations. total-opcom, total-amount-base, total-comissions, total-credit, total-debit RETURN: self." ;; 1- Reset the totals. (setf (slot-value self 'total-opcom) (make-instance DeviseAccount)) (setf (slot-value self 'total-amount-base) (make-instance DeviseAccount)) (setf (slot-value self 'total-comissions) (make-instance DeviseAccount)) (setf (slot-value self 'total-credit) (make-instance DeviseAccount)) (setf (slot-value self 'total-debit) (make-instance DeviseAccount)) ;; 2- Loop over the operations. (let ((ops (operations self)) (op)) (while ops (setq op (car ops) ops (cdr ops)) ;; TODO: We should move this into the Operation class and subclasses... (if (not (eq (class-of op) SplitOp)) (let ((dev (devise op))) ;; Update totals. (account-add (total-opcom self) dev (amount op)) (account-add (total-amount-base self) dev (amount-base op)) (account-add (total-comissions self) dev (comission op)) (if (eq (class-of op) SellOp) (account-add (total-credit self) dev (amount op)) (account-add (total-debit self) dev (amount op))))))) self) (defmethod* add-line ((self Portfolio) (line Line)) " DO: Add the line to the portfolio. PRE: No other line with the same symbol should exist in the portfolio. POST: (eq (line-with-symbol self (symbol line)) line)" (if (line-with-symbol self (symbol line)) (error "There is already a line for the symbol %s in the portfolio." (symbol line))) (setf (slot-value self 'lines) (cons (cons (symbol line) line) (lines self))) self) (defmethod* sort-portfolio-lines ((self Portfolio)) ;; sort-lines is an emacs function! "DO: Sort the lines list on the symbol. RETURN: self." (setf (slot-value self 'lines) (sort (lines self) (lambda (a b) (setq a (symbol-name (car a)) b (symbol-name (car b))) (let ((ia (string-index a ".")) (ib (string-index b "."))) (if ia (if ib (if (string-equal (substring a ia) (substring b ib)) (string-lessp a b) (string-lessp (substring a ia) (substring b ib))) nil) (if ib t (string-lessp a b))))))) self) (defmethod* compute-line-totals ((self Portfolio)) "DO: compute the following totals from the lines. total-invested, total-closed-gains, total-closed-base. RETURN: self." ;; 1- Reset the totals. (setf (slot-value self 'total-invested) (make-instance DeviseAccount)) (setf (slot-value self 'total-closed-gains) (make-instance DeviseAccount)) (setf (slot-value self 'total-closed-base) (make-instance DeviseAccount)) ;; 2- Loop over the lines. (let ((lines (lines self)) (line) (dev)) (while lines (setq line (cdr (car lines)) lines (cdr lines) dev (devise line)) ;; Update totals. (account-add (total-invested self) dev (amount-invested line)) (account-add (total-closed-gains self) dev (closed-gain line)) (account-add (total-closed-base self) dev (closed-buy-amount line)))) self) (defmethod* line-with-symbol ((self Portfolio) symbol) "RETURN: the line whose symbol is SYMBOL, or nil if none exist in the portfolio." (cdr (assoc symbol (lines self)))) ;;;END Portfolio ------------------------------------------------------- ;;;--------------------------------------------------------------------- ;;---------------------------------------------------------------------- ;;--- Main Functions --------------------------------------------------- ;;---------------------------------------------------------------------- (defun portefeuille (operations &rest options) " OPERATIONS est une liste d'opérations boursières au format : ( (DATE QUANTITE DEVISE COURS COMISSION SYMBOL) (2000-10-16 20 EUR 8.98 8.20 ES0132580319) ) Achat : quantité > 0 Vente : quantité < 0 On peut placer 0, 1 ou plusieurs options: 'efface-reste-du-tampon --> efface le reste du tampon à partir du point d'insertion avant d'afficher les résultats. les symboles monétaires définis dans (euro-get-devises) --> affiche les totaux dans la devise indiquée (que les cours soient à jour!). " (let ((portfolio (make-instance Portfolio)) (jlin "---------- --- ---------- ---- -------- ------ ------ ------------\n") (jtit "DATE DEV MONTANT QUTE COURS FRAIS FRAIS% SYMBOL \n") (jlco "---------- --- ---------- ---------- --------- ------\n") (jcom "%-10s %-3s %10.2f %9.2f %5.2f%%\n") (jsol "%-10s %-3s %10.2f \n") (plin "------------ ----- --- ---------- ------ --------- --------- -------\n") (ptit "SYMBOL QUTE DEV PAYE FRAIS REVIENT BENEFICE BENEFI%\n") (pfor "%-13s%5d %-3s %10.2f %6.2f %9.2f %9.2f %6.2f%%\n") (ptot "%-13s %-3s %10.2f %9.2f %6.2f%%\n") (devises-totaux nil) (toutes-les-devises)) ;;; Process options. (mapc (lambda (opt) (cond ((equal opt 'efface-reste-du-tampon) (delete-region (point) (point-max))) ((member opt (euro-get-devises)) (setq devises-totaux (cons opt devises-totaux))) (t (error "Option inconnue '%s'." opt)))) options) (setq devises-totaux (if devises-totaux (remove-duplicates (sort devises-totaux 'compare-slessp-sn)) '(EUR))) ;;; ============================================================ ;;; ;;; === OPERATIONS === ;;; ;;; ============================================================ ;;; (printf "\n") (printf "------------------------------------------------------------------\n") (printf " OPERATIONS\n") (printf "%s" jlin) (printf "%s" jtit) (printf "%s" jlin) ;;; Make the BuySellOp objects from the input lists. (setq operations (mapcar 'make-operation (sort operations 'compare-slessp-sn-c))) (let ((op)) (while operations (setq op (car operations) operations (cdr operations)) ;;; Print the operation. (printf "%s\n" (as-string op)) ;;; Update portfolio & line. (add-operation portfolio op))) (printf "%s" jlin) ;; Compute the operation totals. (compute-operation-totals portfolio) ;;; Print the operation totals. (let ( ;; all these totals are DeviseAccount instances. (t-opcom (total-opcom portfolio)) (t-amount-base (total-amount-base portfolio)) (t-comissions (total-comissions portfolio)) ) (setq toutes-les-devises (sort (remove-duplicates (devises t-opcom)) 'compare-slessp-sn)) (mapc (lambda (devise) (printf jcom "INVEST/DEV" devise (amount-at-devise t-opcom devise) (amount-at-devise t-comissions devise) (percent (amount-at-devise t-comissions devise) (amount-at-devise t-amount-base devise)) "")) toutes-les-devises) (printf "%s" jlco) (mapc (lambda (devise) (printf jcom "INVESTI" devise (account-valuation t-opcom devise) (account-valuation t-comissions devise) (percent (account-valuation t-comissions devise) (account-valuation t-amount-base devise)) "")) devises-totaux) (printf "%s" jlco)) (let* ((devise EUR) (total-credit-v (account-valuation (total-credit portfolio) devise)) (total-debit-v (account-valuation (total-debit portfolio) devise))) (printf "%-10s %3s %10.2f %10.2f\n" "LIQUIDITE" devise total-credit-v total-debit-v) (if (< total-credit-v total-debit-v) (printf "%10s %3s %10.2f\n" "" devise (- total-debit-v total-credit-v)) (printf "%-10s %3s %10.2f\n" "" devise (- total-credit-v total-debit-v)))) (printf "\n") ;;; ============================================================ ;;; ;;; === PORTFOLIO === ;;; ;;; ============================================================ ;;; (printf "%s\n" (make-string (- (length plin) 1) (string-to-char "-"))) (printf " PORTFOLIO\n") (printf "%s" plin) (printf "%s" ptit) (printf "%s" plin) ;;; List the portfolio. (sort-portfolio-lines portfolio) (let ((p-lines (lines portfolio)) (line)) (while p-lines (setq line (cdr (car p-lines)) p-lines (cdr p-lines)) ;;; Print a line. (printf pfor (symbol line) ;; over running position: (quantity line) (devise line) (amount-invested line) (comission line) (paid-per-share line) ;; over closed positions: (closed-gain line) (percent (closed-gain line) (closed-buy-amount line))))) (printf "%s" plin) ;; Compute the line totals. (compute-line-totals portfolio) ;; Print totals. (let ( ;; all these totals are DeviseAccount instances. (t-invested (total-invested portfolio)) (t-closed-gains (total-closed-gains portfolio)) (t-closed-base (total-closed-base portfolio))) (mapc (lambda (devise) (printf ptot "TOTAL/DEV" devise (amount-at-devise t-invested devise) (amount-at-devise t-closed-gains devise) (percent (amount-at-devise t-closed-gains devise) (amount-at-devise t-closed-base devise)))) toutes-les-devises) (printf "%s" plin) (mapc (lambda (devise) (printf ptot "TOTAL" devise (account-valuation t-invested devise) (account-valuation t-closed-gains devise) (percent (account-valuation t-closed-gains devise) (account-valuation t-closed-base devise)))) devises-totaux) (printf "%s" plin)) (printf "\n") portfolio)) (defun affiche-vente (portefeuille taux-benef) (let ((plin "------------ ----- --- --------- ------ --------- -------\n") (ptit "SYMBOL QUTE DEV COURS FRAIS BENEFICE BENEFI%\n") (pfor "%-13s%5d %3s %9.2f %6.2f %9.2f %6.2f%%\n") (p-lines (lines portefeuille)) ) (printf "%s" plin) (printf "%s" ptit) (printf "%s" plin) (while p-lines (let* ((line (cdr (car p-lines))) (avg-comission (/ (comission line) (nb-operations line))) (amount (- (buy-amount line) (sell-amount line))) (quantity (- (buy-quantity line) (sell-quantity line))) (gain 0.0) (sell-price 0.0)) (if (< 0 quantity) (progn (setq sell-price (+ (* (+ 1.0 taux-benef) (paid-per-share line)) (/ avg-comission (quantity line)))) (setq gain (* taux-benef (buy-amount line))) (printf pfor (symbol line) (quantity line) (devise line) sell-price avg-comission gain (* 100.0 taux-benef))))) (setq p-lines (cdr p-lines))) (printf "%s" plin))) (defun show-positions (portefeuille symbol) (let* ((line (cdr (assoc symbol (lines portefeuille)))) (last (last-position line))) (insert (format "%s\n" (make-string 75 ?-))) (insert (format "%s\n" symbol)) (insert (format "%4s %8s %4s %8s %7s %3s %10s %10s %4s %8s\n" "----" "--------" "----" "--------" "-------" "---" "----------" "----------" "----" "--------")) (insert (format "%4s %8s %4s %8s %7s %3s %10s %10s %4s %8s\n" "BuQt" "Buy Amt" "SeQt" "Sel Amt" "Comm" "NOp" "Open Date" "Last Date" "Rest" "Benef.")) (insert (format "%4s %8s %4s %8s %7s %3s %10s %10s %4s %8s\n" "----" "--------" "----" "--------" "-------" "---" "----------" "----------" "----" "--------")) (if (not (is-closed last)) (insert (format "%66s %8.2f\n" "" (/ (- (sell-amount last) (buy-amount last)) (- (sell-quantity last) (buy-quantity last)))))) (mapc (lambda (p) (insert (format "%4d %8.2f %4d %8.2f %7.2f %3d %10s %10s %4d %8.2f\n" (buy-quantity p) (buy-amount p) (sell-quantity p) (sell-amount p) (comission p) (nb-operations p) (open-date p) (last-date p) (- (buy-quantity p) (sell-quantity p) ) (- (sell-amount p) (buy-amount p)) ))) (positions line)) (insert (format "%s\n" (make-string 75 ?-))))) ;;;; THE END ;;;;