Commit 128623fd authored by Dave Cooper's avatar Dave Cooper
Browse files

Merge branch 'devo' of https://github.com/genworks/gendl into devo

parents 4e2417c5 070003ed
("Index" "From Account" "To Account" "Date" "Amount" "Payee")
(0 0 1 3243976597 1000 "djc")
(1 0 1 3243976772 1500 "djc")
(2 1 0 3243976934 500 "kai")
(3 1 0 3243978021 5000 "kai")
(4 2 0 3244075201 500 "")
(5 2 0 3244075201 1000 "")
(6 0 4 3244075201 1300 "")
(7 0 5 3244075201 15 "India Chat House")
(8 0 6 3244075201 45 "Stay Inline - rollerblade wheels")
(9 0 4 3244239636 250 "djc")
(10 2 0 3244161601 540 "djc")
(11 0 5 3244680001 30 "kowloon")
(12 0 7 3244680001 20 "djc")
(13 0 4 3244686333 10 "djc")
(14 0 4 3244686408 10 "djc")
(15 7 5 3244680001 7.0 "sandwich shop in SF")
(16 0 7 3244680001 200 "djc")
(17 7 5 3244680001 18 "restaurant in SF holiday inn")
(18 0 7 3300753601 200 "djc")
(19 0 7 3302481601 200 "david j cooper")
(20 0 7 3302481601 200 "djc")
(21 2 0 3302481601 2000 "djc")
(22 0 7 3337560001 240 "djc")
(23 0 0 3337646401 500 "me")
(24 0 0 3337646401 1000 "me")
(25 0 0 3337646401 300 "foo")
(26 0 0 3337646401 500 "foo")
(27 2 0 3574382401 3000 "David Cooper")
\ No newline at end of file
(27 2 0 3574382401 3000 "David Cooper")
(28 0 7 3615681601 20 "djc")
\ No newline at end of file
......@@ -44,43 +44,20 @@
(nreverse result))
(push transaction result)))))
(account-indices (mapcar
#'(lambda(account)
(the-object account index))
(list-elements (the accounts))))
(account-indices (mapsend (the accounts) :index))
(transaction-indices (mapcar
#'(lambda(transaction)
(the-object transaction index))
(list-elements (the transactions))))
(net-worth (let ((result 0))
(dolist (account (list-elements (the accounts)) result)
(print-variables result)
(print-variables (make-keyword (the-object account account-class)))
(when (eql (make-keyword (string-downcase (the-object account account-class)) )
:asset/liability)
(incf result (the-object account current-balance))))))
(profit (let ((result 0))
(dolist (account (list-elements (the accounts)) result)
(when (eql (make-keyword (string-downcase (the-object account account-class)) )
:income/expense)
(decf result (the-object account current-balance))))))
(transaction-indices (mapsend (the transactions) :index))
(net-worth (the (total-balance :asset/liability)))
(profit (- (the (total-balance :income/expense))))
(balances-hash-table (let ((ht (make-hash-table)))
(dolist (account (list-elements (the accounts)))
(print-variables account)
(setf (gethash (the-object account index) ht)
(the-object account beginning-balance)))
(dolist (transaction (list-elements
(the transactions)) ht)
(print-variables transaction)
(let ((amount (the-object transaction amount)))
(print-variables amount))
(decf
(gethash (the-object transaction from-account) ht)
(the-object transaction amount))
......@@ -91,7 +68,8 @@
:objects
((accounts :type 'account
:sequence (:indices (mapcar #'first (rest (the account-data))))
:data (nth (the-child index) (rest (the account-data)))
:data (find (the-child index) (rest (the account-data))
:key #'first)
:current-balance (gethash (the-child index)
(the balances-hash-table))
:headings (first (the account-data)))
......@@ -99,14 +77,25 @@
(transactions :type 'transaction
:sequence (:indices (mapcar #'first
(rest (the transaction-data))))
:data (nth (the-child index) (rest (the transaction-data)))
:data (find (the-child index) (rest (the transaction-data))
:key #'first)
:headings (first (the transaction-data))))
:functions
(
((total-balance
(account-class-key)
(reduce #'+
(mapsend
(remove-if-not #'(lambda(account)
(eql (the-object account account-class-key)
account-class-key))
(list-elements (the accounts)))
:current-balance)))
(add-transaction!
(&key from-account to-account date amount payee)
(print-variables from-account to-account date amount payee)
(when (or (not (member from-account (the account-indices)))
(not (member to-account (the account-indices)))
(not (numberp amount)) (not (stringp payee))
......@@ -115,14 +104,10 @@
(let ((new-index (1+ (if (null (the transaction-indices)) 0
(apply #'max (the transaction-indices))))))
(the transactions (insert! new-index))
(the (transactions new-index))
;;(the (transactions new-index))
(the (transactions new-index)
(set-slot! :data (list new-index from-account
to-account date amount payee)))
(let ((new-transaction (the (transactions new-index))))
(print-variables new-transaction new-index)))
to-account date amount payee))))
(the save-transactions!))
......@@ -145,7 +130,7 @@
(let ((new-index (1+ (if (null (the account-indices)) 0
(apply #'max (the account-indices))))))
(the accounts (insert! new-index))
(the (accounts new-index))
;;(the (accounts new-index))
(the (accounts new-index)
(set-slot! :data (list new-index name description account-number account-type
account-class beginning-balance))))
......@@ -167,11 +152,15 @@
(data headings current-balance)
:computed-slots
((name (second (the data)))
(
(name (second (the data)))
(description (third (the data)))
(account-number (fourth (the data)))
(account-type (fifth (the data)))
(account-class (sixth (the data)))
(account-class-key (make-keyword (string-downcase (the account-class))))
(beginning-balance (seventh (the data)))))
(define-object transaction (base-object)
......
......@@ -38,23 +38,14 @@
:accounts-sequence (the ledger accounts))
(add-account :type 'add-account
:main-sheet self)
(username :type 'text-form-control
:size 25
:ajax-submit-on-change? t
:default "")
(password :type 'password-form-control
:size 15
:ajax-submit-on-change? t
:default ""))
:main-sheet self))
:functions
(
(write-html-sheet
()
(let ((plist (the add-transaction query-plist)))
(when plist
(the ledger
......@@ -65,6 +56,7 @@
:amount (read-safe-string (getf plist :amount))
:payee (getf plist :payee))))
(the add-transaction (:set-slot! :query-plist nil)))
(let ((plist (the add-account query-plist)))
(when plist
(the ledger (add-account!
......@@ -78,37 +70,48 @@
(the add-account (:set-slot! :query-plist nil)))
(html
(:html
(:head (:title "Personal Ledger"))
(:body
(:h2 (:center "Personal Ledger"))
(with-html-form ()
(:p (:princ (the username html-string)))
(:p (:princ (the password html-string)))
((:input :type :submit :value " OK ")))
(:html
(:head (:title "Personal Ledger"))
(:body
(:h2 (:center "Personal Ledger"))
(:p (:table
(:tr (:td "Net Worth:")
((:td :align :right)
(:b (:tt ((:font
:color (gethash (if (minusp (the ledger net-worth))
:red :green-lime) *color-table*))
(:princ (number-format (the ledger net-worth) 2)))))))
(:tr (:td "Profit/Loss:")
((:td :align :right)
(:b (:tt ((:font
:color (gethash (if (minusp (the ledger profit))
:red :green-lime) *color-table*))
(:princ (number-format (the ledger profit) 2)))))))))
(:p (:ul (:li (the view-accounts
(write-self-link :display-string "View Accounts")))
(:li (the view-transactions
(write-self-link :display-string "View Transactions")))
(:li (the add-transaction
(write-self-link :display-string "Add Transaction")))
(:li (the add-account
(write-self-link :display-string "Add Account")))))))))))
(:p (:table
(:tr (:td "Net Worth:")
((:td :align :right)
(:b (:tt ((:font
:color (gethash (if (minusp (the ledger net-worth))
:red :green-lime) *color-table*))
(:princ (number-format (the ledger net-worth) 2)))))))
(:tr (:td "Profit/Loss:")
((:td :align :right)
(:b (:tt ((:font
:color (gethash (if (minusp (the ledger profit))
:red :green-lime) *color-table*))
(:princ (number-format (the ledger profit) 2)))))))))
(:p (:ul (:li (the view-accounts
(write-self-link :display-string "View Accounts")))
(:li (the view-transactions
(write-self-link :display-string "View Transactions")))
(:li (the add-transaction
(write-self-link :display-string "Add Transaction")))
(:li (the add-account
(write-self-link :display-string "Add Account")))))))))))
(defun adaptive-lessp (item1 item2)
(if (and (numberp item1)
(numberp item2))
(< item1 item2)
(string-lessp (format nil "~a" item1)
(format nil "~a" item2))))
(defun adaptive-greaterp (item1 item2)
(if (and (numberp item1)
(numberp item2))
(> item1 item2)
(string-greaterp (format nil "~a" item1)
(format nil "~a" item2))))
(define-object view-accounts (base-ajax-sheet)
......@@ -116,24 +119,59 @@
:computed-slots
((accounts (list-elements (the account-sequence)))
(headings (the-object (first (the accounts)) headings)))
:functions
((write-html-sheet
()
(html
(:html
(:head (:title "Account Listing"))
(:body
(:h2 (:center "Account Listing"))
(:p (the (:write-back-link)))
(:p ((:table :bgcolor :black)
((:tr :bgcolor :yellow)
(dolist (heading (append (rest (the headings))
(list "Current Balance")))
(html (:th (:princ heading)))))
(dolist (account (the accounts))
(html
(accounts-sorted
(if (the sort-key)
(safe-sort (the accounts)
(ecase (the sort-order)
(:ascending #'adaptive-lessp)
(:descending #'adaptive-greaterp))
:key #'(lambda(account)
(the-object account (evaluate (the sort-key)))))
(the accounts)))
(sort-key nil :settable)
(sort-order :ascending :settable)
(headings (the-object (first (the accounts)) headings))
(main-sheet-body (with-cl-who-string ()
(when gwl:*developing?* (str (the development-links)))
(:h2 (:center "Account Listing"))
(:p (the (:write-back-link :display-string "Home")))
(:p (str (the main-section main-div)))
(:p (the (:write-back-link :display-string "Home"))))))
:functions ((set-sort-key!
(&key sort-key)
(if (eql sort-key (the sort-key))
(the (set-slot! :sort-order (ecase (the sort-order)
(:ascending :descending)
(:descending :ascending))))
(the (set-slot! :sort-key sort-key)))))
:objects
((main-section
:type 'sheet-section
:inner-html
(with-cl-who-string ()
(:p ((:table :bgcolor :black)
((:tr :bgcolor :yellow)
(dolist (heading (append (rest (the headings))
(list "Current Balance")))
(let ((ajax-call (the (gdl-ajax-call
:function-key :set-sort-key!
:arguments (list :sort-key
(make-keyword
(format nil "~(~a~)"
(glisp:replace-regexp
heading " " "-"))))))))
(htm (:th ((:span :onclick ajax-call
:style "color: blue; cursor: pointer;")
(str heading)))))))
(dolist (account (the accounts-sorted))
(htm
((:tr :bgcolor (gethash :grey-light-very *color-table*))
(dolist (slot (list :name :description :account-number :account-type
:account-class :beginning-balance :current-balance))
......@@ -142,60 +180,81 @@
((:beginning-balance :current-balance)
(number-format raw-value 2))
(otherwise raw-value))))
(html ((:td :align (case slot
(htm ((:td :align (case slot
((:beginning-balance :current-balance)
:right)
(otherwise :left)))
(case slot ((:beginning-balance :current-balance)
(html (:tt (format *html-stream* "$~$" value))))
(otherwise (html (:princ value)))))))))))))
(:p (the (:write-back-link)))))))))
(htm (:tt (fmt "$~$" value))))
(otherwise (htm (str value)))))))))))))))))
(define-object view-transactions (base-ajax-sheet)
:input-slots (transaction-sequence accounts-sequence)
:computed-slots ((transactions (list-elements
(the transaction-sequence)))
(headings (the-object (first (the transactions))
headings)))
:functions
((write-html-sheet
()
(html
(:html
(:head (:title "Transaction Listing"))
(:body
(:h2 (:center "Transaction Listing"))
(:p (the (:write-back-link)))
(:p ((:table :bgcolor :black)
((:tr :bgcolor :yellow)
(dolist (heading (rest (the headings)))
(html (:th (:princ heading)))))
(dolist (transaction (the transactions))
(html
((:tr :bgcolor (gethash :grey-light-very
*color-table*))
(dolist (slot (list :from-account :to-account
:date :amount :payee ))
(let* ((raw-value
(the-object transaction (evaluate slot)))
(value (case slot
((:from-account :to-account)
(the :accounts-sequence
(get-member raw-value) :name))
(:date (iso-date raw-value))
(:amount (number-format raw-value 2))
(otherwise raw-value))))
(html ((:td :align (case slot (:amount :right)
(otherwise :left)))
(case slot (:amount
(html
(:tt (format *html-stream*
"$~$" value))))
(otherwise
(html (:princ value)))))))))))))
(:p (the (:write-back-link)))))))))
:computed-slots ((transactions (list-elements (the transaction-sequence)))
(headings (the-object (first (the transactions)) headings))
(main-sheet-body (with-cl-who-string ()
(:h2 (:center "Transaction Listing"))
(:p (the (:write-back-link :display-string "Home")))
(:p (str (the main-section main-div)))
(:p (the (:write-back-link :display-string "Home"))))))
:functions ((delete-transaction!
(index)
(the ledger transactions (delete! index))
(the ledger save-transactions!)))
:objects ((delete-buttons :type 'button-form-control
:sequence (:size (length (the transactions)))
:label "Delete"
:onclick
(the (gdl-ajax-call
:function-key :delete-transaction!
:arguments (list (the-object (nth (the-child index)
(the transactions))
index)))))
(main-section
:type 'sheet-section
:inner-html (with-cl-who-string ()
((:table :bgcolor :black)
((:tr :bgcolor :yellow)
(dolist (heading (rest (the headings)))
(htm (:th (str heading)))) (:th ""))
(let ((count -1))
(dolist (transaction (the transactions))
(incf count)
(htm
((:tr :bgcolor (gethash :grey-light-very
*color-table*))
(dolist (slot (list :from-account :to-account
:date :amount :payee ))
(let* ((raw-value
(the-object transaction (evaluate slot)))
(value (case slot
((:from-account :to-account)
(the :accounts-sequence
(get-member raw-value) :name))
(:date (iso-date raw-value))
(:amount (number-format raw-value 2))
(otherwise raw-value))))
(htm ((:td :align (case slot (:amount :right)
(otherwise :left)))
(case slot (:amount
(htm
(:tt (fmt "$~$" value))))
(otherwise
(htm (str value))))))))
(:td (str (the (delete-buttons count)
form-control-string))))))))))))
(define-object add-transaction (base-ajax-sheet)
......@@ -210,7 +269,7 @@
(:html
(:head (:title "Add Transaction"))
(:body (:h2 (:center "Add Transaction"))
(:p (the (:write-back-link)))
(:p (the (:write-back-link :display-string "Home")))
(with-html-form ()
(:p ((:table :bgcolor :black)
(:tr ((:td :bgcolor :yellow) "From Account")
......@@ -252,7 +311,7 @@
(:html
(:head (:title "Add Account"))
(:body (:h2 (:center "Add Account"))
(:p (the (:write-back-link)))
(:p (the (:write-back-link :display-string "Home")))
(with-html-form ()
(:p ((:table :bgcolor :black)
(:tr ((:td :bgcolor :yellow) "Name")
......
......@@ -805,7 +805,7 @@ Contact Genworks if you need this documented."
(define-object button-form-control (base-form-control)
:input-slots
((:label (the value))
((label (the value))
(content (the :label))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment