Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
128623fd
Commit
128623fd
authored
Aug 13, 2014
by
Dave Cooper
Browse files
Merge branch 'devo' of
https://github.com/genworks/gendl
into devo
parents
4e2417c5
070003ed
Changes
4
Hide whitespace changes
Inline
Side-by-side
demos/ledger/data/transactions.lisp
View file @
128623fd
(
"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
demos/ledger/source/assembly.lisp
View file @
128623fd
...
...
@@ -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
)
...
...
demos/ledger/source/html.lisp
View file @
128623fd
...
...
@@ -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
))))
(
htm
l
((
:td
:align
(
case
slot
(
htm
((
:td
:align
(
case
slot
((
:beginning-balance
:current-balance
)
:right
)
(
otherwise
:left
)))
(
case
slot
((
:beginning-balance
:current-balance
)
(
htm
l
(
:tt
(
f
ormat
*html-stream*
"$~$"
value
))))
(
otherwise
(
htm
l
(
:princ
value
)))))))))))))
(
:p
(
the
(
:write-back-link
)))))))))
(
htm
(
:tt
(
f
mt
"$~$"
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"
)
...
...
gwl/form-elements/source/primitives.lisp
View file @
128623fd
...
...
@@ -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
))
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment