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

Move ^cell and ^attenuated to utils.

Browse Source
main
Edward L Platt 2 years ago
parent 30a1496f31
commit f6ec88e682
2 changed files with 42 additions and 115 deletions
Show Stats Download Patch File Download Diff File

121
deliberate.scm
Unescape Escape View File

@ -17,39 +17,10 @@
#:use-module (goblins)
#:use-module (goblins vrun)
#:use-module (goblins actor-lib methods)
#:use-module (deliberate utils)
#:use-module (deliberate preference)
#:export (^deliberation ^deliberation-info ^ranked-choice-vote ^ranked-ballot ^ranked-preference))
;; Constructor for ^cell
;; Stores a single updatable value
;;
;; Parameters:
;; value: The value to store
;;
;; Messages:
;; get: returns the current value
;; set new-value: updates object to store new-value
;;
(define (^cell bcom value)
(methods
((get) value)
((set new-value) (bcom (^cell bcom new-value)))
))
;; Constructor for ^attenuated
;; Attenuates another goblins object
;;
;; Parameters:
;; obj: Object to attenuate
;; allowed: List of messages that will be delegated to obj, others will
;; raise an error
;;
(define (^attenuated _bcom obj allowed)
(lambda (message)
(if (memq message allowed)
($ obj message)
(error (format #f "Message not permitted: [~a]" message))
)))
;; Constructor for ^deliberation-info
;; Information about a deliberation
;;
@ -82,48 +53,21 @@
(define (^deliberation _bcom title)
(let (
(info (spawn ^deliberation-info title))
(alternatives (spawn ^cell '()))
(alternatives (spawn ^alternatives title))
)
(methods
((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)
((add-alternative alt) ($ alternatives 'add alt))
((get-alternatives) ($ alternatives 'alternatives))
)))
;; Constructor for ^ranked-preference
;; One constituent's preferences as an ordered ranking
;;
;; Parameters:
;; ranking: A list of alternatives from most to least preferred
;;
;; Messages:
;; get: Return the ranked list of alternatives
;; set new-ranking: Updates the ranking to new-ranking
;; get-rank alternative: Return the rank of alternative (1 is most
;; preferred).
;;
(define (^ranked-preference bcom ranking)
(methods
((get) ranking)
((set new-ranking) (bcom (^ranked-preference bcom new-ranking)))
((get-rank alternative)
(let ((alt-index
(list-index (lambda (alt) (equal? alt alternative)) ranking)))
(if (number? alt-index)
(+ 1 alt-index)
(+ 1 (length ranking)))))
))
;; Constructor for ^ranked-ballot
;; Allow one constituent to update their rank-order preference
;;
;; Parameters:
;; deliberation-info: deliberation-info relevnt to this ballot
;; alternatives: cell containing a list of alternatives
;; deliberation-info: ^deliberation-info relevnt to this ballot
;; alternatives: ^alternatives object representing possible outcomes
;;
;; Messages:
;; update-vote f: Updates the constituent's vote on this ballot.
@ -170,54 +114,3 @@
(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)
(define (range low high)
(if (eq? low high)
'()
(cons low (range (+ 1 low) high))))
;; Combine lists component-wise
;; Similar to python zip()
;;
;; Parameters:
;; args: Any number of lists
;;
;; Returns:
;; A list. The nth element is a list of the
;; nth elements of each argument
;;
(define (zip . args)
(if (or (nil? args) (memq '() args))
'()
(cons (map car args)
(apply zip (map cdr args)))))
;; Reorder one list by another
;; A reordering is applied to lst such that the same reordering would
;; Put rank in asending oder.
;;
;; Parameters:
;; lst: The list to reorder
;; ranks: The list to sort by
;;
;; Returns:
;; A reordered copy of lst
;;
(define (reorder lst ranks)
(let* ((pairs (zip lst ranks))
(ranked-pairs
(filter (lambda (pair) (not (eq? #f (cadr pair))))
pairs))
(sorted-pairs
(sort ranked-pairs (lambda (a b) (< (cadr a) (cadr b))))))
(map car sorted-pairs)))

36
deliberate/utils.scm
Unescape Escape View File

@ -1,7 +1,41 @@
(define-module (deliberate utils)
#:use-module (srfi srfi-1)
#:export (const-list group-by range reorder string-count zip))
#:use-module (goblins)
#:use-module (goblins actor-lib methods)
#:export (^attenuated ^cell const-list group-by range reorder string-count zip))
;; Constructor for ^cell
;; Stores a single updatable value
;;
;; Parameters:
;; value: The value to store
;;
;; Messages:
;; get: returns the current value
;; set new-value: updates object to store new-value
;;
(define (^cell bcom value)
(methods
((get) value)
((set new-value) (bcom (^cell bcom new-value)))
))
;; Constructor for ^attenuated
;; Attenuates another goblins object
;;
;; Parameters:
;; obj: Object to attenuate
;; allowed: List of messages that will be delegated to obj, others will
;; raise an error
;;
(define (^attenuated _bcom obj allowed)
(lambda (message)
(if (memq message allowed)
($ obj message)
(error (format #f "Message not permitted: [~a]" message))
)))
;; Return a list of given length with each element equal to a given value
(define (const-list length value)
(if (= length 0)
'()

Write Preview
Loading…
Cancel
Save