diff --git a/deliberate.scm b/deliberate.scm index 4a79a60..37d74fc 100644 --- a/deliberate.scm +++ b/deliberate.scm @@ -12,18 +12,12 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. -(use-modules (srfi srfi-1) - (goblins) - (goblins vrun) - (goblins actor-lib methods)) - -;; Commented out until I figure out how to set up a dev environment -; (define-module (deliberate) -; #:use-module (srfi srfi-1) -; #:use-module (goblins) -; #:use-module (goblins vrun) -; #:use-module (goblins actor-lib methods) -; #:export (^decision ^ranked-choice-vote ^ranked-ballot ^ranked-preference)) +(define-module (deliberate) + #:use-module (srfi srfi-1) + #:use-module (goblins) + #:use-module (goblins vrun) + #:use-module (goblins actor-lib methods) + #:export (^deliberation ^deliberation-info ^ranked-choice-vote ^ranked-ballot ^ranked-preference)) ;; Constructor for ^cell ;; Stores a single updatable value @@ -41,7 +35,6 @@ ((set new-value) (bcom (^cell bcom new-value))) )) - ;; Constructor for ^attenuated ;; Attenuates another goblins object ;; @@ -57,11 +50,27 @@ (error (format #f "Message not permitted: [~a]" message)) ))) -;; Constructor for ^decision -;; A decision with multiple possible alternative outcomes +;; Constructor for ^deliberation-info +;; Information about a deliberation +;; +;; Parameters: +;; title: Title of the deliberation +;; +;; Messages: +;; get-title: Return the title +;; set-title: new-title: Set the title to new-title +;; +(define (^deliberation-info bcom title) + (methods + ((get-title) title) + ((set-title) (bcom (^decision bcom title))) + )) + +;; Constructor for ^deliberation +;; A deliberation with multiple possible alternative outcomes ;; ;; Parameters: -;; title: Title of the decision +;; title: Title of the deliberation ;; ;; Messages: ;; get-title: Return the title @@ -70,18 +79,19 @@ ;; represented by the string alt. ;; get-alternatives: Return a list of all alteratives ;; -(define (^decision _bcom title) +(define (^deliberation _bcom title) (let ( - (title (spawn ^cell title)) + (info (spawn ^deliberation-info title)) (alternatives (spawn ^cell '())) ) (methods - ((get-title) ($ title 'get)) - ((set-title new-title) ($ title 'set new-title)) + ((get-title) ($ info 'get-title)) + ((set-title new-title) ($ info 'set-title new-title)) ((add-alternative alt) (define old-alts ($ alternatives 'get)) ($ alternatives 'set (cons alt old-alts))) ((get-alternatives) ($ alternatives 'get)) + ((debug-alternatives) alternatives) ))) ;; Constructor for ^ranked-preference @@ -112,7 +122,8 @@ ;; Allow one constituent to update their rank-order preference ;; ;; Parameters: -;; decision: The decision this ballot applies to +;; deliberation-info: deliberation-info relevnt to this ballot +;; alternatives: cell containing a list of alternatives ;; ;; Messages: ;; update-vote f: Updates the constituent's vote on this ballot. @@ -122,13 +133,13 @@ ;; get-preference: Returns a ^ranked-preference associated with this ballot. ;; The object is attenuated to be read-only. ;; -(define (^ranked-ballot _bcom decision) +(define (^ranked-ballot _bcom deliberation-info alternatives) (define ranking (spawn ^ranked-preference '())) (methods ((update-vote f) - (let* ((alternatives ($ decision 'get-alternatives)) - (ranks (f alternatives)) - (new-ranking (reorder alternatives ranks))) + (let* ((alt-list ($ alternatives 'get)) + (ranks (f alt-list)) + (new-ranking (reorder alt-list ranks))) ($ ranking 'set new-ranking))) ((get-preference) (spawn ^attenuated ranking '(get get-rank))) )) @@ -137,24 +148,33 @@ ;; A updateable vote using ranked choice preferences ;; ;; Parameters: -;; decision: The decision this vote refers to +;; deliberation-info: deliberation-info relevant to this vote +;; alternatives: cell containig list of altenatives ;; ;; Messages: ;; get-ballots: Return the list of ballots ;; add-ballot: Add a new ballot to this vote and return it ;; -(define (^ranked-choice-vote bcom decision) +(define (^ranked-choice-vote bcom deliberation-info alternatives) (define ballots (spawn ^cell '())) (methods ((get-ballots) ($ ballots 'get)) ((add-ballot) - (define ballot (spawn ^ranked-ballot decision)) + (define ballot (spawn ^ranked-ballot deliberation-info alternatives)) (define old-ballots ($ ballots 'get)) ($ ballots 'set (cons ballot old-ballots)) ballot) + ((get-profile) + ;; This is a very space-heavy representation + ;; Would be better to use a hashmap keyed on rankings with counts as values + (map (lambda (ballot) ($ ($ ballot 'get-preference) 'get)) + ballots)) )) +(define (^social-preference-borda _bcom profile) + #f) + ;;; UTILITY CODE ;; Return a list of integers in the half-open interval [low, high) diff --git a/test-deliberate.scm b/test-deliberate.scm index cb25d8e..7ed0db0 100644 --- a/test-deliberate.scm +++ b/test-deliberate.scm @@ -1,10 +1,15 @@ +(use-modules (deliberate) + (goblins) + (goblins vrun) + (goblins actor-lib methods)) + (define a-vat (spawn-vat)) (define-vat-run a-run a-vat) -(define dec (a-run (spawn ^decision "Bike Shed"))) -(a-run ($ dec 'add-alternative "red")) -(a-run ($ dec 'add-alternative "green")) -(a-run ($ dec 'add-alternative "blue")) -(define vote (a-run (spawn ^ranked-choice-vote dec))) +(define delib (a-run (spawn ^deliberation "Bike Shed"))) +(a-run ($ delib 'add-alternative "red")) +(a-run ($ delib 'add-alternative "green")) +(a-run ($ delib 'add-alternative "blue")) +(define vote (a-run (spawn ^ranked-choice-vote delib ($ delib 'debug-alternatives)))) (define ballot (a-run ($ vote 'add-ballot))) (define (rank312 alts) '(3 1 2))