Skip to content

Commit

Permalink
creating litters and moving packs
Browse files Browse the repository at this point in the history
  • Loading branch information
@nebogeo
nebogeo committed Feb 26, 2018
1 parent c494c0f commit bfed910
Show file tree
Hide file tree
Showing 5 changed files with 128 additions and 79 deletions.
22 changes: 19 additions & 3 deletions android/app/src/main/assets/group-comp.scm
View file
Expand Up @@ -203,9 +203,25 @@
(db-mongooses-by-pack-female) #f
(lambda (individuals)
(set-current! 'entity-type "group-comp")
(entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
(list)))
)
(entity-update-single-value! (ktv "pregnant" "varchar" (assemble-array individuals)))
(let ((litter (db-current-litter)))
(msg litter)
(cond
((null? litter)
;; create a new litter for this pack!
(entity-create! db "sync" "litter" (init-litter (ktv-get (get-current 'pack '()) "unique_id")))
(set-current! 'entity-type "group-comp")
(list
(if (null? (db-current-litter))
(ok-dialog "litter-create-prob"
"Tried to create new litter and failed..."
(lambda () '()))
(ok-dialog "litter-create-prob"
(string-append
"Created new litter for pack "
(ktv-get (get-current 'pack '()) "name"))
(lambda () '())))))
(else (list)))))))
(update-grid-selector-enabled "gc-preg-choose" (get-current 'gc-not-present '()))
(update-grid-selector-checked "gc-preg-choose" "pregnant")))
(lambda (fragment) '())
Expand Down
10 changes: 6 additions & 4 deletions android/app/src/main/assets/litter.scm
View file
Expand Up @@ -13,9 +13,11 @@
;; 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 (init-litter)
(define (init-litter pack-id)
;; retreve (and increment) the pack's id info
(set-current! 'entity-type "pack")
(entity-init! db "sync" "pack" (dbg (get-entity-by-unique db "sync" pack-id)))
(msg (entity-get-value "unique_id"))

(let ((letter (entity-get-value "litter-code-letter"))
(number (entity-get-value "litter-code-number"))
(parent (entity-get-value "unique_id")))
Expand All @@ -35,7 +37,7 @@
(db-filter
db "sync" "litter"
(list
(list "pack-id" "varchar" "=" (ktv-get (get-current 'pack '()) "unique_id"))
(list "dob" "varchar" "d<" 30))))
(list "parent" "varchar" "=" (ktv-get (get-current 'pack '()) "unique_id"))
(list "date" "varchar" "d<" 30))))


8 changes: 4 additions & 4 deletions android/app/src/main/assets/mongoose.scm
View file
Expand Up @@ -51,6 +51,7 @@
"preg-focal-affil"

"lifehist-event"
"movepack-event"
))

(define pup-focal-export
Expand Down Expand Up @@ -444,11 +445,9 @@
'())))

(define (db-mongoose-packs)
(msg "db-mongooses-by-pack")
(db-filter db "sync" "pack" '()))

(define (db-mongooses-by-pack)
(msg "db-mongooses-by-pack")
(db-filter
db "sync" "mongoose"
(list (list "pack-id" "varchar" "=" (ktv-get (get-current 'pack '()) "unique_id")))))
Expand All @@ -474,7 +473,6 @@
(list "gender" "varchar" "not like" "male"))))



;; (y m d h m s)
(define (date-minus-months d ms)
(let ((year (list-ref d 0))
Expand Down Expand Up @@ -800,6 +798,7 @@
(equal? type "group-alarm")
(equal? type "group-move")
(equal? type "note")
(equal? type "movepack-event")
(equal? type "lifehist-event"))
(cons
(mbutton
Expand Down Expand Up @@ -1234,7 +1233,8 @@
(let ((search-results
(if parent
(db-filter-only db table entity-type
(list (list "parent" "varchar" "=" parent))
(list (list "parent" "varchar" "=" parent)
(list "date" "varchar" "d<" 90))
(map
(lambda (id)
(list id "varchar"))
Expand Down
165 changes: 98 additions & 67 deletions android/app/src/main/assets/starwisp.scm
View file
Expand Up @@ -575,10 +575,10 @@
(entity-set-value! "litter-code-number" "int" (string->number v))
'()))))

(build-list-widget db "sync" "Recent litters" (list "name" "date")
(build-list-widget db "sync" "Recent litters (last 90 days)" (list "name" "date")
"litter" "update-litter"
(lambda () (ktv-get (get-current 'pack '()) "unique_id"))
(lambda () (init-litter)))
(lambda () (init-litter (ktv-get (get-current 'pack '()) "unique_id"))))
(build-lifehist 'pack)
(horiz
(mbutton2 "manage-pack-back" "Cancel" (lambda () (list (finish-activity 1))))
Expand Down Expand Up @@ -683,65 +683,70 @@

(activity
"update-individual"
(vert
(text-view (make-id "title") "Update Mongoose" 40 fillwrap)
(spacer 10)
(text-view (make-id "update-individual-name-text") "Name" 30 fillwrap)
(edit-text (make-id "update-individual-name") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "name" "varchar" v) '()))
(text-view (make-id "update-individual-name-text") "Gender" 30 fillwrap)
(mspinner "update-individual-gender" list-gender
(lambda (v) (entity-set-value! "gender" "varchar" (spinner-choice list-gender v)) '()))
(text-view (make-id "update-individual-dob-text") "Date of Birth" 30 fillwrap)
(horiz
(text-view (make-id "update-individual-dob") "00/00/00" 25 fillwrap)
(button (make-id "date") "Set date" 30 fillwrap
(lambda ()
(list (date-picker-dialog
"update-individual-date"
(lambda (day month year)
(let ((datestring (date->string (list year (+ month 1) day))))
(entity-set-value! "dob" "varchar" datestring)
(list
(update-widget
'text-view
(get-id "update-individual-dob") 'text datestring))))))))
(button (make-id "update-unknown-date") "Unknown" 30 fillwrap
(lambda ()
(entity-set-value! "dob" "varchar" "Unknown")
(list (update-widget 'text-view (get-id "update-individual-dob") 'text "Unknown"))))
)

(text-view (make-id "update-individual-litter-text") "Litter code" 30 fillwrap)
(edit-text (make-id "update-individual-litter-code") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "litter-code" "varchar" v) '()))
(text-view (make-id "update-individual-chip-text") "Chip code" 30 fillwrap)
(edit-text (make-id "update-individual-chip-code") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "chip-code" "varchar" v) '()))
(text-view (make-id "update-individual-collar-text") "Collar weight" 30 fillwrap)
(edit-text (make-id "update-individual-collar-weight") "" 30 "numeric" fillwrap
(lambda (v) (entity-set-value! "collar-weight" "real" (string->number v)) '()))
(spacer 10)
(horiz
(mtoggle-button2 "update-individual-delete" "Delete"
(lambda (v)
(entity-set-value! "deleted" "int" (if v 1 0))
(list)))
(mtoggle-button2 "update-individual-died" "Died"
(lambda (v)
(entity-set-value! "deleted" "int" (if v 2 0))
(list))))

(build-lifehist 'male)

(horiz
(mbutton2 "update-individual-cancel" "Cancel"
(lambda () (list (finish-activity 2))))
(mbutton2 "update-individual-done" "Done"
(lambda ()
(entity-update-values!)
(list (finish-activity 2)))))
)
(scroll-view-vert
0 (layout 'fill-parent 'wrap-content 0.75 'centre 0)
(list
(vert
(text-view (make-id "title") "Update Mongoose" 40 fillwrap)
(spacer 10)
(text-view (make-id "update-individual-name-text") "Name" 30 fillwrap)
(edit-text (make-id "update-individual-name") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "name" "varchar" v) '()))
(text-view (make-id "update-individual-name-text") "Gender" 30 fillwrap)
(mspinner "update-individual-gender" list-gender
(lambda (v) (entity-set-value! "gender" "varchar" (spinner-choice list-gender v)) '()))
(text-view (make-id "update-individual-dob-text") "Date of Birth" 30 fillwrap)
(horiz
(text-view (make-id "update-individual-dob") "00/00/00" 25 fillwrap)
(button (make-id "date") "Set date" 30 fillwrap
(lambda ()
(list (date-picker-dialog
"update-individual-date"
(lambda (day month year)
(let ((datestring (date->string (list year (+ month 1) day))))
(entity-set-value! "dob" "varchar" datestring)
(list
(update-widget
'text-view
(get-id "update-individual-dob") 'text datestring))))))))
(button (make-id "update-unknown-date") "Unknown" 30 fillwrap
(lambda ()
(entity-set-value! "dob" "varchar" "Unknown")
(list (update-widget 'text-view (get-id "update-individual-dob") 'text "Unknown"))))
)

(text-view (make-id "update-individual-litter-text") "Litter code" 30 fillwrap)
(edit-text (make-id "update-individual-litter-code") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "litter-code" "varchar" v) '()))
(text-view (make-id "update-individual-chip-text") "Chip code" 30 fillwrap)
(edit-text (make-id "update-individual-chip-code") "" 30 "text" fillwrap
(lambda (v) (entity-set-value! "chip-code" "varchar" v) '()))
(text-view (make-id "update-individual-collar-text") "Collar weight" 30 fillwrap)
(edit-text (make-id "update-individual-collar-weight") "" 30 "numeric" fillwrap
(lambda (v) (entity-set-value! "collar-weight" "real" (string->number v)) '()))
(spacer 10)
(horiz
(mtoggle-button2 "update-individual-delete" "Delete"
(lambda (v)
(entity-set-value! "deleted" "int" (if v 1 0))
(list)))
(mtoggle-button2 "update-individual-died" "Died"
(lambda (v)
(entity-set-value! "deleted" "int" (if v 2 0))
(list))))

(build-grid-selector "move-pack-list" "button" "Move pack")

(build-lifehist 'male)

(horiz
(mbutton2 "update-individual-cancel" "Cancel"
(lambda () (list (finish-activity 2))))
(mbutton2 "update-individual-done" "Done"
(lambda ()
(entity-update-values!)
(list (finish-activity 2)))))
)))
(lambda (activity arg)
(activity-layout activity))
(lambda (activity arg)
Expand All @@ -767,7 +772,32 @@
(if (eqv? (entity-get-value "deleted") 1) 1 0))
(update-widget 'toggle-button (get-id "update-individual-died") 'checked
(if (eqv? (entity-get-value "deleted") 2) 1 0))
)))
(populate-grid-selector
"move-pack-list" "button" (db-mongoose-packs) #f
(lambda (pack)
(list
(alert-dialog
"move-pack-done"
"Move mongoose into new pack: are you sure?"
(lambda (v)
(cond
((eqv? v 1)
(let ((src-pack (get-entity-by-unique db "sync" (entity-get-value "pack-id"))))
(entity-create!
db "stream" "movepack-event"
(list
(ktv "mongoose-id" "varchar" (entity-get-value "unique_id"))
(ktv "mongoose-name" "varchar" (entity-get-value "name"))
(ktv "pack-dst-id" "varchar" (ktv-get pack "unique_id"))
(ktv "pack-dst-name" "varchar" (ktv-get pack "name"))
(ktv "pack-src-id" "varchar" (entity-get-value "pack-id"))
(ktv "pack-src-name" "varchar" (ktv-get src-pack "name"))))
(entity-set-value! "pack-id" "varchar" (ktv-get pack "unique_id"))
(entity-update-values!)
(list (finish-activity 1))))
(else
(list)))))))
))))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
Expand Down Expand Up @@ -992,11 +1022,12 @@

(build-lifehist 'litter)

(mtoggle-button2 "update-litter-delete" "Delete"
(lambda (v)
(entity-set-value! "deleted" "int" (if v 1 0))
(list)))

(mbutton2 "update-litter-delete" "Delete"
(lambda ()
(entity-set-value! "deleted" "int" 1)
(entity-update-values!)
(list (finish-activity 2))))

(horiz
(mbutton2 "update-litter-cancel" "Cancel"
(lambda () (list (finish-activity 2))))
Expand Down
2 changes: 1 addition & 1 deletion eavdb/entity-filter.ss
View file
Expand Up @@ -70,7 +70,7 @@
r "join " table "_value_" (filter-type i) " "
"as " var " on "
var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and ( "
"(julianday(" var ".value)-julianday('now'))" (substring (filter-op i) 1 (string-length (filter-op i))) " ? "
"julianday('now')-julianday(" var ".value)" (substring (filter-op i) 1 (string-length (filter-op i))) " ? "
"or " var ".value like 'unknown') "))
((equal? (substring (filter-op i) 0 1) "t")
;; time version
Expand Down

0 comments on commit bfed910

Please sign in to comment.