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.

(define-module (deliberate)
  #:use-module (srfi srfi-1)
  #: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 ^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 deliberation
;;
;; 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 (^deliberation _bcom title)
  (let (
	(info (spawn ^deliberation-info title))
	(alternatives (spawn ^alternatives title))
	)
    (methods
     ((get-title) ($ info 'get-title))
     ((set-title new-title) ($ info 'set-title new-title))
     ((add-alternative alt) ($ alternatives 'add alt))
     ((get-alternatives) ($ alternatives 'alternatives))
     )))

;; Constructor for ^ranked-ballot
;; Allow one constituent to update their rank-order preference
;;
;; Parameters:
;;   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.
;;     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 deliberation-info alternatives)
  (define ranking (spawn ^ranked-preference '()))
  (methods
   ((update-vote f)
    (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)))
   ))
   
;; Constructor for ^ranked-choice-vote
;; A updateable vote using ranked choice preferences
;;
;; Parameters:
;;   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 deliberation-info alternatives)
  (define ballots (spawn ^cell '()))
  (methods
   ((get-ballots) ($ ballots 'get))
   ((add-ballot)
    (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))
   ))