Skip to content

Commit

Permalink
added litters with autoincrementing ids
Browse files Browse the repository at this point in the history
  • Loading branch information
@nebogeo
nebogeo committed Feb 23, 2018
1 parent 2bd3246 commit b0cd6b1
Show file tree
Hide file tree
Showing 7 changed files with 311 additions and 167 deletions.
1 change: 1 addition & 0 deletions android/app/src/main/AndroidManifest.xml
View file
Expand Up @@ -35,6 +35,7 @@
<activity android:name="ReviewActivity" android:configChanges="orientation"></activity>
<activity android:name="ReviewItemActivity" android:configChanges="orientation"></activity>
<activity android:name="ReviewCollectionActivity" android:configChanges="orientation"></activity>
<activity android:name="UpdateLitterActivity" android:configChanges="orientation"></activity>
</application>

<uses-permission android:name="android.permission.WRITE_EXTERNAL_STORAGE" />
Expand Down
50 changes: 0 additions & 50 deletions android/app/src/main/assets/dbsync.scm
View file
Expand Up @@ -850,56 +850,6 @@
'text-view (get-id (string-append (symbol->string display-id) "-lon"))
'text (number->string lon))))))


;; a standard builder for list widgets of entities and a
;; make new button, to add defaults to the list
(define (build-list-widget db table title entity-type edit-activity parent-fn ktv-default-fn)
(vert-colour
colour-two
(horiz
(mtitle-scale title)
(button
(make-id (string-append (symbol->string title) "-add"))
(mtext-lookup 'add-item-to-list)
40 (layout 100 'wrap-content 1 'centre 5)
(lambda ()
(entity-create!
db table entity-type
(ktvlist-merge
(ktv-default-fn)
(list (ktv "parent" "varchar" (parent-fn)))))
(list (update-list-widget db table entity-type edit-activity (parent-fn))))))
(linear-layout
(make-id (string-append entity-type "-list"))
'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
(list 0 0 0 0)
(list))))

;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity parent)
(let ((search-results
(if parent
(db-filter-only db table entity-type
(list (list "parent" "varchar" "=" parent))
(list (list "name" "varchar")))
(db-all db table entity-type))))
(update-widget
'linear-layout
(get-id (string-append entity-type "-list"))
'contents
(if (null? search-results)
(list (mtext 'list-empty))
(map
(lambda (e)
(button
(make-id (string-append "list-button-" (ktv-get e "unique_id")))
(or (ktv-get e "name") "Unamed item")
40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(list (start-activity edit-activity 0 (ktv-get e "unique_id"))))))
search-results)))))

(define (delete-button)
(mbutton
'delete
Expand Down
145 changes: 79 additions & 66 deletions android/app/src/main/assets/life-history.scm
View file
@@ -1,4 +1,17 @@

;; Mongoose 2000 Copyright (C) 2018 FoAM Kernow
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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 Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.

(define list-pack-lifehist
(list
Expand Down Expand Up @@ -53,72 +66,72 @@
(lifehist-types (if (equal? gender "female") 'female 'male))))
(update-widget 'text-view (get-id "lifehist-title") 'text
(string-append "New life history event for this " (lifehist-text gender)))))

(define (build-lifehist type)
(linear-layout
(make-id "") 'vertical fillwrap lh-bgcol
(list
(text-view (make-id "lifehist-title") (string-append "New life history event for this " (lifehist-text type)) 30 fillwrap)
(horiz
(vert
(horiz
(mtext 0 "Date:")
(mtext "lifehist-date-view" (date->string (date-time))))
(mbutton-large
"lifehist-date" "Set date"
(lambda ()
(list (date-picker-dialog
"lifehist-date"
(lambda (day month year)
(let ((datestring (date->string (list year (+ month 1) day))))
(set-current! 'lifehist-date datestring)
(list
(update-widget
'text-view (get-id "lifehist-date-view")
'text datestring)))))))))
(vert
(mtext 0 "Code")
(mspinner "lifehist-type"
(lifehist-types type)
(lambda (v)
(set-current!
'lifehist-code
(spinner-choice (lifehist-types type) v))
'())))
(vert
(mtext 0 "")
(mcolour-button-large
"lifehist-record" "Record"
lh-col
(lambda ()
(list
(alert-dialog
"lifehist-check"
"Recording life history event: are you sure?"
(lambda (v)
(cond
((eqv? v 1)
;; using entity-create! so as not to disturb the current
;; pack/litter/individual being currently edited in
;; memory via the rest of the interface
(entity-create!
db "stream" "lifehist-event"
(list
(ktv "date" "varchar" (get-current 'lifehist-date (date-time->string (date-time))))
(ktv "type" "varchar" (symbol->string type))
(ktv "code" "varchar" (get-current 'lifehist-code "none"))
(ktv "entity-uid" "varchar"
(cond
((eq? type 'pack) (ktv-get (get-current 'pack ()) "unique_id"))
((eq? type 'litter) (ktv-get (get-current 'litter ()) "unique_id"))
(else (ktv-get (get-current 'individual ()) "unique_id"))))
(ktv "entity-name" "varchar"
(cond
((eq? type 'pack) (ktv-get (get-current 'pack ()) "name"))
((eq? type 'litter) (ktv-get (get-current 'litter ()) "name"))
(else (ktv-get (get-current 'individual ()) "name"))))))
'())
(else
(list)))))))))))))
(vert-colour
lh-bgcol
(text-view (make-id "lifehist-title") (string-append "New life history event for this " (lifehist-text type)) 30 fillwrap)
(horiz
(vert
(horiz
(mtext 0 "Date:")
(mtext "lifehist-date-view" (date->string (date-time))))
(mbutton-large
"lifehist-date" "Set date"
(lambda ()
(list (date-picker-dialog
"lifehist-date"
(lambda (day month year)
(let ((datestring (date->string (list year (+ month 1) day))))
(set-current! 'lifehist-date datestring)
(list
(update-widget
'text-view (get-id "lifehist-date-view")
'text datestring)))))))))
(vert
(mtext 0 "Code")
(mspinner "lifehist-type"
(lifehist-types type)
(lambda (v)
(set-current!
'lifehist-code
(spinner-choice (lifehist-types type) v))
'())))
(vert
(mtext 0 "")
(mcolour-button-large
"lifehist-record" "Record"
lh-col
(lambda ()
(list
(alert-dialog
"lifehist-check"
"Recording life history event: are you sure?"
(lambda (v)
(cond
((eqv? v 1)
;; using entity-create! so as not to disturb the current
;; pack/litter/individual being currently edited in
;; memory via the rest of the interface
(entity-create!
db "stream" "lifehist-event"
(list
(ktv "date" "varchar" (get-current 'lifehist-date (date-time->string (date-time))))
(ktv "type" "varchar" (symbol->string type))
(ktv "code" "varchar" (get-current 'lifehist-code "none"))
(ktv "entity-uid" "varchar"
(cond
((eq? type 'pack) (ktv-get (get-current 'pack ()) "unique_id"))
((eq? type 'litter) (ktv-get (get-current 'litter ()) "unique_id"))
(else (ktv-get (get-current 'individual ()) "unique_id"))))
(ktv "entity-name" "varchar"
(cond
((eq? type 'pack) (ktv-get (get-current 'pack ()) "name"))
((eq? type 'litter) (ktv-get (get-current 'litter ()) "name"))
(else (ktv-get (get-current 'individual ()) "name"))))))
'())
(else
(list))))))))))))



77 changes: 77 additions & 0 deletions android/app/src/main/assets/mongoose.scm
View file
Expand Up @@ -192,6 +192,12 @@
;(define of-col (list 51 204 51 255))
;(define prf-col (list 255 51 51 255))

(define large-text-size 30)
(define button-text-size 25)
(define normal-text-size 20)
(define small-text-size 15)
(define margin-size 10)
(define list-colour (list 255 255 255 50))

(define pf-bgcol (list 255 204 51 127))
(define gp-bgcol (list 255 102 0 127))
Expand Down Expand Up @@ -533,6 +539,12 @@
(list "dob" "varchar" "t<"
(date->string (date-minus-months (date-time) 6))))))

(define (db-current-litters)
(db-filter
db "sync" "litter"
(list
(list "pack-id" "varchar" "=" (ktv-get (get-current 'pack '()) "unique_id"))
(list "date" "varchar" "d<" 30))))

(define (tri-state entity-type id text key)
(linear-layout
Expand Down Expand Up @@ -1178,3 +1190,68 @@
(lambda ()
(list)))))
(else (fn))))


;; a standard builder for list widgets of entities and a
;; make new button, to add defaults to the list - edit-activity
;; is called when the + button is pressed
(define (build-list-widget db table title title-ids entity-type edit-activity parent-fn ktv-default-fn)
(vert-colour
list-colour
(horiz
(mtitle "" title)
(button
(make-id (string-append title "-add"))
"+" 40 (layout 100 'wrap-content 1 'centre 5)
(lambda ()
(let ((id (entity-create!
db table entity-type
(ktvlist-merge
(ktv-default-fn)
(list (ktv "parent" "varchar" (parent-fn)))))))
(list (start-activity edit-activity 0 id))))))

(linear-layout
(make-id (string-append entity-type "-list"))
'vertical
(layout 'fill-parent 'wrap-content 1 'centre 20)
(list 0 0 0 0)
(list))))

(define (make-list-widget-title e title-ids)
(if (eqv? (length title-ids) 1)
(ktv-get e (car title-ids))
(dbg (foldl
(lambda (id r)
(if (equal? r "")
(ktv-get e id)
(string-append r " " (ktv-get e id))))
""
title-ids))))

;; pull db data into list of button widgets
(define (update-list-widget db table title-ids entity-type view-activity parent)
(let ((search-results
(if parent
(db-filter-only db table entity-type
(list (list "parent" "varchar" "=" parent))
(map
(lambda (id)
(list id "varchar"))
title-ids))
(db-all db table entity-type))))
(update-widget
'linear-layout
(get-id (string-append entity-type "-list"))
'contents
(if (null? search-results)
(list (mtext "" "No litters found"))
(map
(lambda (e)
(button
(make-id (string-append "list-button-" (ktv-get e "unique_id")))
(make-list-widget-title e title-ids)
button-text-size (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(list (start-activity view-activity 0 (ktv-get e "unique_id"))))))
search-results)))))

0 comments on commit b0cd6b1

Please sign in to comment.