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)
  #:use-module (deliberate irv)
  #:use-module (deliberate borda)
  #: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:
;;   title: Return the title
;;   set-title: new-title: Set the title to `new-title`
;;
(define (^deliberation-info bcom title)
  (methods
   ((title) title)
   ((set-title new-title)
    (bcom (^deliberation-info bcom new-title)))
   ))

;; Constructor for ^deliberation
;; A deliberation including discussion and multiple votes.
;;
;; TODO: Add discussion functionality
;;
;; Parameters:
;;   title: Title of the deliberation
;;
;; Messages:
;;   title: Return the title
;;   set-title: new-title: Set the title to `new-title`
;;   votes: Return the list of votes
;;   add-vote: Create a new vote and add it to this deliberation. The new
;;     vote is returned
;;
(define (^deliberation _bcom title)
  (define info (spawn ^deliberation-info title))
  (define votes (spawn ^cell '()))
  (methods
   ((title) ($ info 'title))
   ((set-title new-title) ($ info 'set-title new-title))
   ((votes) ($ votes 'get))
   ((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
;; Allow one constituent to update their rank-order preference
;;
;; Parameters:
;;   deliberation-info: ^deliberation-info relevnt to this ballot
;;   preference: A ^ranked-preference object to associate with this ballot
;;
;; 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.
;;     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.
;;   ranking: Returns a ranked list of alternatives corresponding to the
;;     current state of this ballot's vote.
;;
(define (^ranked-ballot _bcom deliberation-info preference)
  (methods
   ((alternatives)
    (define alternatives ($ preference 'alternatives))
    ($ alternatives 'alternatives))
   ((question)
    (define alternatives ($ preference 'alternatives))
    ($ alternatives 'question))
   ((update-vote f)
    ($ preference 'set f))
   ((ranking)
    ($ preference 'ranked))
   ))
   
;; Constructor for ^ranked-choice-vote
;; A updateable vote using ranked-choice ballots.
;;
;; Parameters:
;;   deliberation-info: ^deliberation-info object
;;   question: String describing the question being voted on
;;
;; Messages:
;;   ballots: Return the list of ^ranked-ballot objects
;;   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.
;;
;;   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 alternatives (spawn ^alternatives question '()))
  (define profile (spawn ^ranked-profile alternatives))
  (methods
   ((ballots) ($ ballots 'get))
   ((add-ballot)
    ;; 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))
    ($ ballots 'set (cons ballot old-ballots))
    ;; Return the new ballot
    ballot)
   ((add-alternative alt) ($ alternatives 'add alt))
   
   ((irv-winner)
    (social-choice-irv ($ profile 'counts)))
   ((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)))
   ))