goblins-deliberate/deliberate.scm

;;; 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)))))))