elplatt
/
goblins-deliberate
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Finish ^deliberation code and tests.

Browse Source
main
Edward L Platt 2 years ago
parent e67ae2c12d
commit bd2bb2646d
2 changed files with 175 additions and 54 deletions
Show Stats Download Patch File Download Diff File

125
deliberate.scm
Unescape Escape View File

@ -19,6 +19,8 @@
#:use-module (goblins actor-lib methods) #:use-module (goblins actor-lib methods)
#:use-module (deliberate utils) #:use-module (deliberate utils)
#:use-module (deliberate preference) #:use-module (deliberate preference)
#:use-module (deliberate irv)
#:use-module (deliberate borda)
#:export (^deliberation ^deliberation-info ^ranked-choice-vote ^ranked-ballot ^ranked-preference)) #:export (^deliberation ^deliberation-info ^ranked-choice-vote ^ranked-ballot ^ranked-preference))
;; Constructor for ^deliberation-info ;; Constructor for ^deliberation-info
@ -28,89 +30,130 @@
;; title: Title of the deliberation ;; title: Title of the deliberation
;; ;;
;; Messages: ;; Messages:
;; get-title: Return the title ;; title: Return the title
;; set-title: new-title: Set the title to new-title ;; set-title: new-title: Set the title to `new-title`
;; ;;
(define (^deliberation-info bcom title) (define (^deliberation-info bcom title)
(methods (methods
((get-title) title) ((title) title)
((set-title) (bcom (^decision bcom title))) ((set-title new-title)
(bcom (^deliberation-info bcom new-title)))
)) ))
;; Constructor for ^deliberation ;; Constructor for ^deliberation
;; A deliberation with multiple possible alternative outcomes ;; A deliberation including discussion and multiple votes.
;;
;; TODO: Add discussion functionality
;; ;;
;; Parameters: ;; Parameters:
;; title: Title of the deliberation ;; title: Title of the deliberation
;; ;;
;; Messages: ;; Messages:
;; get-title: Return the title ;; title: Return the title
;; set-title: new-title: Set the title to new-title ;; set-title: new-title: Set the title to `new-title`
;; add-alternative alt: Add a new alternative (possible outcome) ;; votes: Return the list of votes
;; represented by the string alt. ;; add-vote: Create a new vote and add it to this deliberation. The new
;; get-alternatives: Return a list of all alteratives ;; vote is returned
;; ;;
(define (^deliberation _bcom title) (define (^deliberation _bcom title)
(let ( (define info (spawn ^deliberation-info title))
(info (spawn ^deliberation-info title)) (define votes (spawn ^cell '()))
(alternatives (spawn ^alternatives title))
)
(methods (methods
((get-title) ($ info 'get-title)) ((title) ($ info 'title))
((set-title new-title) ($ info 'set-title new-title)) ((set-title new-title) ($ info 'set-title new-title))
((add-alternative alt) ($ alternatives 'add alt)) ((votes) ($ votes 'get))
((get-alternatives) ($ alternatives 'alternatives)) ((add-vote question)
))) (define vote (spawn ^ranked-choice-vote info question))
(define old-votes ($ votes 'get))
($ votes 'set (cons vote old-votes))
vote)
))
;; Constructor for ^ranked-ballot ;; Constructor for ^ranked-ballot
;; Allow one constituent to update their rank-order preference ;; Allow one constituent to update their rank-order preference
;; ;;
;; Parameters: ;; Parameters:
;; deliberation-info: ^deliberation-info relevnt to this ballot ;; deliberation-info: ^deliberation-info relevnt to this ballot
;; alternatives: ^alternatives object representing possible outcomes ;; preference: A ^ranked-preference object to associate with this ballot
;; ;;
;; Messages: ;; Messages:
;; alternatives: Returns a list of the alternatives being voted on
;; question: Return the question being voted on
;; update-vote f: Updates the constituent's vote on this ballot. ;; update-vote f: Updates the constituent's vote on this ballot.
;; The procedure f is called with one parameter: the list of available ;; The procedure f is called with one parameter: the list of available
;; alternatives. f must return a list of rank preferences ;; alternatives. f must return a list of rank preferences
;; (1 is most preferred) corresponding to the alternatives componentwise. ;; (1 is most preferred) corresponding to the alternatives componentwise.
;; get-preference: Returns a ^ranked-preference associated with this ballot. ;; ranking: Returns a ranked list of alternatives corresponding to the
;; The object is attenuated to be read-only. ;; current state of this ballot's vote.
;; ;;
(define (^ranked-ballot _bcom deliberation-info alternatives) (define (^ranked-ballot _bcom deliberation-info preference)
(define ranking (spawn ^ranked-preference '()))
(methods (methods
((alternatives)
(define alternatives ($ preference 'alternatives))
($ alternatives 'alternatives))
((question)
(define alternatives ($ preference 'alternatives))
($ alternatives 'question))
((update-vote f) ((update-vote f)
(let* ((alt-list ($ alternatives 'get)) ($ preference 'set f))
(ranks (f alt-list)) ((ranking)
(new-ranking (reorder alt-list ranks))) ($ preference 'ranked))
($ ranking 'set new-ranking)))
((get-preference) (spawn ^attenuated ranking '(get get-rank)))
)) ))
;; Constructor for ^ranked-choice-vote ;; Constructor for ^ranked-choice-vote
;; A updateable vote using ranked choice preferences ;; A updateable vote using ranked-choice ballots.
;; ;;
;; Parameters: ;; Parameters:
;; deliberation-info: deliberation-info relevant to this vote ;; deliberation-info: ^deliberation-info object
;; alternatives: cell containig list of altenatives ;; question: String describing the question being voted on
;; ;;
;; Messages: ;; Messages:
;; get-ballots: Return the list of ballots ;; ballots: Return the list of ^ranked-ballot objects
;; add-ballot: Add a new ballot to this vote and return it ;; add-ballot: Add a new ^ranked-ballot to this vote and return it
;; add-alternative: Add a new alternative to this vote
;;
;; irv-winner: Return a list containing the winner (or winners in case of
;; a tie) according to the instant-runoff method.
;; irv-preference: Return a list of lists corresponding to the social
;; preference for alternatives according to the instant-runoff method.
;; Inner lists represent alternatives tied for the same position.
;; ;;
(define (^ranked-choice-vote bcom deliberation-info alternatives) ;; borda-winner: Return a list containing the winner (or winners in case
;; of a tie) according to the Borda method.
;; borda-preference: Return a list of lists corresponding to the social
;; preference for alternatives according to the Borda method. Inner lists
;; represent alternatives tied for the same position.
;;
(define (^ranked-choice-vote bcom deliberation-info question)
(define ballots (spawn ^cell '())) (define ballots (spawn ^cell '()))
(define alternatives (spawn ^alternatives question '()))
(define profile (spawn ^ranked-profile alternatives))
(methods (methods
((get-ballots) ($ ballots 'get)) ((ballots) ($ ballots 'get))
((add-ballot) ((add-ballot)
(define ballot (spawn ^ranked-ballot deliberation-info alternatives)) ;; Create a new preference in the profile
(define preference ($ profile 'add-preference))
;; Create the ballot
(define ballot
(spawn ^ranked-ballot deliberation-info preference))
;; Add ballot to list
(define old-ballots ($ ballots 'get)) (define old-ballots ($ ballots 'get))
($ ballots 'set (cons ballot old-ballots)) ($ ballots 'set (cons ballot old-ballots))
;; Return the new ballot
ballot) ballot)
((get-profile) ((add-alternative alt) ($ alternatives 'add alt))
;; This is a very space-heavy representation
;; Would be better to use a hashmap keyed on rankings with counts as values ((irv-winner)
(map (lambda (ballot) ($ ($ ballot 'get-preference) 'get)) (social-choice-irv ($ profile 'counts)))
ballots)) ((irv-preference)
(social-preference-irv ($ profile 'counts)))
((borda-winner)
(social-choice-borda
($ alternatives 'alternatives)
($ profile 'counts)))
((borda-preference)
(social-preference-borda
($ alternatives 'alternatives)
($ profile 'counts)))
)) ))

100
test-deliberate.scm
Unescape Escape View File

@ -1,16 +1,94 @@
(use-modules (deliberate) ;;; Copyright 2022 Edward L. Platt
(goblins) ;;;
(goblins vrun) ;;; Licensed under the Apache License, Version 2.0 (the "License");
(goblins actor-lib methods)) ;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-module (tests test-preference)
#:use-module (srfi srfi-64)
#:use-module (goblins)
#:use-module (goblins vrun)
#:use-module (goblins actor-lib methods)
#:use-module (deliberate))
(define a-vat (spawn-vat)) (define a-vat (spawn-vat))
(define-vat-run a-run a-vat) (define-vat-run a-run a-vat)
(define delib (a-run (spawn ^deliberation "Bike Shed")))
(a-run ($ delib 'add-alternative "red")) (test-begin "test-deliberate")
(a-run ($ delib 'add-alternative "green"))
(a-run ($ delib 'add-alternative "blue")) ;; Tests for ^deliberation-info
(define vote (a-run (spawn ^ranked-choice-vote delib ($ delib 'debug-alternatives)))) (define info (a-run (spawn ^deliberation-info "Power Generator")))
(test-equal "Power Generator"
(a-run ($ info 'title)))
(a-run ($ info 'set-title "Energy"))
(test-equal "Energy"
(a-run ($ info 'title)))
;; Tests for ^deliberation
(define delib (a-run (spawn ^deliberation "Power Generator")))
(test-equal "Power Generator"
(a-run ($ delib 'title)))
;; Tests for ^ranked-choice-vote
(define vote (a-run ($ delib 'add-vote "What type of generator?")))
(a-run ($ delib 'votes))
(a-run ($ vote 'ballots))
;; Add alternatives
(a-run ($ vote 'add-alternative "solar"))
(a-run ($ vote 'add-alternative "wind"))
(a-run ($ vote 'add-alternative "hydro"))
;; Tests for ^ranked-ballot
(define ballot (a-run ($ vote 'add-ballot))) (define ballot (a-run ($ vote 'add-ballot)))
(define (rank31f alts) '(3 1 #f)) (a-run ($ vote 'ballots))
(a-run ($ ballot 'update-vote rank31f)) (a-run ($ ballot 'alternatives))
(a-run ($ ballot 'question))
;; Example ranking functions
(define (f-wind-solar-hydro alts) '(3 1 2))
(define (f-hydro-solar-wind alts) '(1 3 2))
(define (f-solar-wind-hydro alts) '(3 2 1))
;; Cast a single vote
(a-run ($ ballot 'update-vote f-wind-solar-hydro))
(test-equal '("wind" "solar" "hydro")
(a-run ($ ballot 'ranking)))
;; Add more votes to test voting methods
(let ((ballot (a-run ($ vote 'add-ballot))))
(a-run ($ ballot 'update-vote f-wind-solar-hydro)))
(let ((ballot (a-run ($ vote 'add-ballot))))
(a-run ($ ballot 'update-vote f-hydro-solar-wind)))
(let ((ballot (a-run ($ vote 'add-ballot))))
(a-run ($ ballot 'update-vote f-hydro-solar-wind)))
(let ((ballot (a-run ($ vote 'add-ballot))))
(a-run ($ ballot 'update-vote f-solar-wind-hydro)))
;; Test instant-runoff
(test-equal '("wind")
(a-run ($ vote 'irv-winner)))
;; Test Borda method
(test-equal '("solar")
(a-run ($ vote 'borda-winner)))
(test-end "test-deliberate")

Write Preview
Loading…
Cancel
Save