You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
199 lines
5.6 KiB
Scheme
199 lines
5.6 KiB
Scheme
2 years ago
|
;;; Copyright 2022 Edward L. Platt
|
||
|
;;;
|
||
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
;;; 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.
|
||
|
|
||
|
(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))
|
||
|
|
||
|
;; 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 ^decision
|
||
|
;; A decision with multiple possible alternative outcomes
|
||
|
;;
|
||
|
;; Parameters:
|
||
|
;; title: Title of the decision
|
||
|
;;
|
||
|
;; Messages:
|
||
|
;; get-title: Return the title
|
||
|
;; set-title: new-title: Set the title to new-title
|
||
|
;; add-alternative alt: Add a new alternative (possible outcome)
|
||
|
;; represented by the string alt.
|
||
|
;; get-alternatives: Return a list of all alteratives
|
||
|
;;
|
||
|
(define (^decision _bcom title)
|
||
|
(let (
|
||
|
(title (spawn ^cell title))
|
||
|
(alternatives (spawn ^cell '()))
|
||
|
)
|
||
|
(methods
|
||
|
((get-title) ($ title 'get))
|
||
|
((set-title new-title) ($ title 'set new-title))
|
||
|
((add-alternative alt)
|
||
|
(define old-alts ($ alternatives 'get))
|
||
|
($ alternatives 'set (cons alt old-alts)))
|
||
|
((get-alternatives) ($ alternatives 'get))
|
||
|
)))
|
||
|
|
||
|
;; 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:
|
||
|
;; decision: The decision this ballot applies to
|
||
|
;;
|
||
|
;; Messages:
|
||
|
;; update-vote f: Updates the constituent's vote on this ballot.
|
||
|
;; The procedure f is called with one parameter: the list of available
|
||
|
;; alternatives. f must return a list of rank preferences
|
||
|
;; (1 is most preferred) corresponding to the alternatives componentwise.
|
||
|
;; get-preference: Returns a ^ranked-preference associated with this ballot.
|
||
|
;; The object is attenuated to be read-only.
|
||
|
;;
|
||
|
(define (^ranked-ballot _bcom decision)
|
||
|
(define ranking (spawn ^ranked-preference '()))
|
||
|
(methods
|
||
|
((update-vote f)
|
||
|
(let* ((alternatives ($ decision 'get-alternatives))
|
||
|
(ranks (f alternatives))
|
||
|
(new-ranking (reorder alternatives ranks)))
|
||
|
($ ranking 'set new-ranking)))
|
||
|
((get-preference) (spawn ^attenuated ranking '(get get-rank)))
|
||
|
))
|
||
|
|
||
|
;; Constructor for ^ranked-choice-vote
|
||
|
;; A updateable vote using ranked choice preferences
|
||
|
;;
|
||
|
;; Parameters:
|
||
|
;; decision: The decision this vote refers to
|
||
|
;;
|
||
|
;; 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 ballots (spawn ^cell '()))
|
||
|
(methods
|
||
|
((get-ballots) ($ ballots 'get))
|
||
|
((add-ballot)
|
||
|
(define ballot (spawn ^ranked-ballot decision))
|
||
|
(define old-ballots ($ ballots 'get))
|
||
|
($ ballots 'set (cons ballot old-ballots))
|
||
|
ballot)
|
||
|
))
|
||
|
|
||
|
|
||
|
;;; 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)))
|
||
|
(map car (sort pairs (lambda (a b) (< (cadr a) (cadr b)))))))
|
||
|
|
||
|
|
||
|
|