From b0cd6b148dd5f8e8da6f3353ae8fe13bbbd493f3 Mon Sep 17 00:00:00 2001 From: dave griffiths Date: Fri, 23 Feb 2018 18:49:33 +0000 Subject: [PATCH] added litters with autoincrementing ids --- android/app/src/main/AndroidManifest.xml | 1 + android/app/src/main/assets/dbsync.scm | 50 ------ android/app/src/main/assets/life-history.scm | 145 +++++++++------- android/app/src/main/assets/mongoose.scm | 77 +++++++++ android/app/src/main/assets/starwisp.scm | 163 ++++++++++++++---- .../src/main/java/foam/starwisp/starwisp.java | 2 + eavdb/entity-filter.ss | 40 +++-- 7 files changed, 311 insertions(+), 167 deletions(-) diff --git a/android/app/src/main/AndroidManifest.xml b/android/app/src/main/AndroidManifest.xml index e6169d7..e3c47c0 100644 --- a/android/app/src/main/AndroidManifest.xml +++ b/android/app/src/main/AndroidManifest.xml @@ -35,6 +35,7 @@ + diff --git a/android/app/src/main/assets/dbsync.scm b/android/app/src/main/assets/dbsync.scm index 6b6932e..70e3591 100644 --- a/android/app/src/main/assets/dbsync.scm +++ b/android/app/src/main/assets/dbsync.scm @@ -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 diff --git a/android/app/src/main/assets/life-history.scm b/android/app/src/main/assets/life-history.scm index 5946049..7e0ed06 100644 --- a/android/app/src/main/assets/life-history.scm +++ b/android/app/src/main/assets/life-history.scm @@ -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 . (define list-pack-lifehist (list @@ -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)))))))))))) diff --git a/android/app/src/main/assets/mongoose.scm b/android/app/src/main/assets/mongoose.scm index 76e39a7..a76a3f8 100644 --- a/android/app/src/main/assets/mongoose.scm +++ b/android/app/src/main/assets/mongoose.scm @@ -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)) @@ -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 @@ -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))))) diff --git a/android/app/src/main/assets/starwisp.scm b/android/app/src/main/assets/starwisp.scm index 57f28eb..3f715ad 100644 --- a/android/app/src/main/assets/starwisp.scm +++ b/android/app/src/main/assets/starwisp.scm @@ -473,7 +473,6 @@ (lambda (activity) '()) (lambda (activity requestcode resultcode) '())) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (activity @@ -532,50 +531,85 @@ (activity "manage-individual" - (vert - (text-view (make-id "title") "Update pack" 40 fillwrap) - (text-view (make-id "manage-individual-pack-name") "Pack:" 30 fillwrap) - (build-grid-selector "manage-individuals-list" "button" "Choose individual") - (horiz - (mbutton2 "manage-individuals-new" "New individual" (lambda () (list (start-activity "new-individual" 2 "")))) - (mbutton2 "manage-individuals-delete" "Delete pack" - (lambda () - (list - (alert-dialog - "delete-pack-dialog" - "Delete this pack: are you sure?" - (lambda (v) - (cond - ((eqv? v 1) - (list - (alert-dialog - "delete-really-pack-dialog" - "Really delete this pack: are you absolutely sure?" - (lambda (v) - (cond - ((eqv? v 1) - (set-current! 'entity-type "pack") - (entity-update-single-value! (ktv "deleted" "int" 1)) - (list (finish-activity 1))) - (else - (list))))))) - (else (list))))))))) - (build-lifehist 'pack) - (mbutton2 "choose-obs-back" "Back" (lambda () (list (finish-activity 1)))) - ) + (scroll-view-vert + 0 (layout 'fill-parent 'wrap-content 0.75 'centre 0) + (list + (vert + (text-view (make-id "title") "Update pack" 40 fillwrap) + (text-view (make-id "manage-pack-name") "Pack:" 30 fillwrap) + (build-grid-selector "manage-pack-list" "button" "Choose individual") + (horiz + (mbutton2 "manage-pack-new" "New individual" (lambda () (list (start-activity "new-individual" 2 "")))) + (mbutton2 "manage-pack-delete" "Delete pack" + (lambda () + (list + (alert-dialog + "delete-pack-dialog" + "Delete this pack: are you sure?" + (lambda (v) + (cond + ((eqv? v 1) + (list + (alert-dialog + "delete-really-pack-dialog" + "Really delete this pack: are you absolutely sure?" + (lambda (v) + (cond + ((eqv? v 1) + (set-current! 'entity-type "pack") + (entity-update-single-value! (ktv "deleted" "int" 1)) + (list (finish-activity 1))) + (else + (list))))))) + (else (list))))))))) + (vert + (mtext (make-id "") "Current litter code") + (horiz + (medit-text "litter-code-letter" "Letter" + "normal" + (lambda (v) + (entity-set-value! "litter-code-letter" "varchar" v) + '())) + (medit-text "litter-code-number" "Number" + "numeric" + (lambda (v) + (entity-set-value! "litter-code-number" "int" (string->number v)) + '())))) + + (build-list-widget db "sync" "Recent litters" (list "name" "date") + "litter" "update-litter" + (lambda () (msg "pack parent") (dbg (ktv-get (get-current 'pack '()) "unique_id"))) + (lambda () (init-litter))) + (build-lifehist 'pack) + (horiz + (mbutton2 "manage-pack-back" "Cancel" (lambda () (list (finish-activity 1)))) + (mbutton2 "manage-pack-done" "Done" + (lambda () + (entity-update-values!) + (list (finish-activity 2)))))))) (lambda (activity arg) (activity-layout activity)) (lambda (activity arg) + (msg "pack ---------------------------") (entity-init! db "sync" "pack" (get-current 'pack #f)) (list + (update-list-widget + db "sync" (list "name" "date") "litter" "update-litter" + (ktv-get (get-current 'pack '()) "unique_id")) (populate-grid-selector - "manage-individuals-list" "button" + "manage-pack-list" "button" (db-mongooses-by-pack) #f (lambda (individual) (set-current! 'individual individual) (list (start-activity "update-individual" 2 "")))) - (update-widget 'text-view (get-id "manage-individual-pack-name") 'text + (update-widget 'text-view (get-id "manage-pack-name") 'text (string-append "Pack: " (ktv-get (get-current 'pack '()) "name"))) + + (update-widget 'text-view (get-id "litter-code-letter") 'text + (or (entity-get-value "litter-code-letter") "")) + (update-widget 'text-view (get-id "litter-code-number") 'text + (or (entity-get-value "litter-code-number") "")) + )) (lambda (activity) '()) (lambda (activity) '()) @@ -717,7 +751,7 @@ (lambda (activity arg) (entity-init! db "sync" "individual" (get-current 'individual #f)) (let ((individual (get-current 'individual '()))) - (append + (append (update-lifehist (ktv-get individual "gender")) (list (update-widget 'edit-text (get-id "update-individual-name") 'text @@ -938,4 +972,63 @@ (lambda (activity) '()) (lambda (activity requestcode resultcode) '())) + + (activity + "update-litter" + (vert + (text-view (make-id "title") "Update Litter" 40 fillwrap) + (text-view (make-id "litter-pack-text") "" 30 fillwrap) + (spacer 10) + (vert + (text-view (make-id "update-litter-date-text") "00/00/00" 25 fillwrap) + (button (make-id "date") "Set date" 30 fillwrap + (lambda () + (list (date-picker-dialog + "update-litter-date" + (lambda (day month year) + (let ((datestring (date->string (list year (+ month 1) day)))) + (entity-set-value! "date" "varchar" datestring) + (list + (update-widget + 'text-view + (get-id "update-litter-date") 'text datestring))))))))) + + + (build-lifehist 'litter) + + (mtoggle-button2 "update-litter-delete" "Delete" + (lambda (v) + (entity-set-value! "deleted" "int" (if v 1 0)) + (list))) + + (horiz + (mbutton2 "update-litter-cancel" "Cancel" + (lambda () (list (finish-activity 2)))) + (mbutton2 "update-litter-done" "Done" + (lambda () + (entity-update-values!) + (list (finish-activity 2))))) + + ) + (lambda (activity arg) + (activity-layout activity)) + (lambda (activity arg) + (set-current! 'litter (get-entity-by-unique db "sync" arg)) + (entity-init! db "sync" "litter" (get-current 'litter '())) + (list + (update-widget + 'text-view (get-id "litter-pack-text") 'text + (string-append "Pack: " (ktv-get (get-current 'pack '()) "name"))) + (update-widget 'text-view (get-id "update-litter-date-text") 'text + (entity-get-value "date")) + + )) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity) '()) + (lambda (activity requestcode resultcode) '())) + + + ) diff --git a/android/app/src/main/java/foam/starwisp/starwisp.java b/android/app/src/main/java/foam/starwisp/starwisp.java index 9629334..25ebf03 100644 --- a/android/app/src/main/java/foam/starwisp/starwisp.java +++ b/android/app/src/main/java/foam/starwisp/starwisp.java @@ -78,6 +78,7 @@ public class starwisp extends StarwispActivity ActivityManager.RegisterActivity("manage-individual",ManageIndividualActivity.class); ActivityManager.RegisterActivity("new-individual",NewIndividualActivity.class); ActivityManager.RegisterActivity("update-individual",UpdateIndividualActivity.class); + ActivityManager.RegisterActivity("update-litter",UpdateLitterActivity.class); ActivityManager.RegisterActivity("tag-location",TagLocationActivity.class); ActivityManager.RegisterActivity("sync",SyncActivity.class); @@ -117,6 +118,7 @@ public void onCreate(Bundle savedInstanceState) m_Scheme.Load("dbsync.scm"); m_Scheme.Load("mongoose.scm"); m_Scheme.Load("life-history.scm"); + m_Scheme.Load("litter.scm"); m_Scheme.Load("pup-focal.scm"); m_Scheme.Load("oestrus-focal.scm"); m_Scheme.Load("preg-focal.scm"); diff --git a/eavdb/entity-filter.ss b/eavdb/entity-filter.ss index 2a16d5a..fb27280 100644 --- a/eavdb/entity-filter.ss +++ b/eavdb/entity-filter.ss @@ -63,20 +63,30 @@ (define (build-query-chunk i r table) (let ((var (mangle (string-append (filter-key i) "_var")))) ;; add a query chunk - (if (equal? (substring (filter-op i) 0 1) "t") - ;; time version - (string-append - r "join " table "_value_" (filter-type i) " " - "as " var " on " - var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and ( " - var ".value " (substring (filter-op i) 1 (string-length (filter-op i))) " DateTime(?) " - "or " var ".value like 'unknown') ") - ;; normal version - (string-append - r "join " table "_value_" (filter-type i) " " - "as " var " on " - var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and " - var ".value " (filter-op i) " ? ")))) + (cond + ((equal? (substring (filter-op i) 0 1) "d") + ;; a days comparison version (should replace time version) + (string-append + 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))) " ? " + "or " var ".value like 'unknown') ")) + ((equal? (substring (filter-op i) 0 1) "t") + ;; time version + (string-append + r "join " table "_value_" (filter-type i) " " + "as " var " on " + var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and ( " + var ".value " (substring (filter-op i) 1 (string-length (filter-op i))) " DateTime(?) " + "or " var ".value like 'unknown') ")) + ;; normal version + (else + (string-append + r "join " table "_value_" (filter-type i) " " + "as " var " on " + var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and " + var ".value " (filter-op i) " ? "))))) (define (build-query table filter typed) @@ -138,8 +148,6 @@ (cdr s)))))) - - (define (filter-entities-inc-deleted db table type filter) (let ((q (build-query-inc-deleted table filter))) (let ((s (apply