Refactor preference module to improve consistency.
parent
743d9a8c65
commit
0082ed981e
@ -0,0 +1,121 @@
|
||||
;;; 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 preference)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (goblins)
|
||||
#:use-module (goblins vrun)
|
||||
#:use-module (goblins actor-lib methods)
|
||||
#:use-module (deliberate utils)
|
||||
#:export (^alternatives ^ranked-preference ^ranked-profile))
|
||||
|
||||
;; Constructor for ^alternatives
|
||||
;; A set of alternative outcomes to a question.
|
||||
;;
|
||||
;; Parameters:
|
||||
;; question: String describing the question being considered
|
||||
;; alternatives: list of strings describing possible alternatives
|
||||
;;
|
||||
;; Messages:
|
||||
;; question: Return the question string
|
||||
;; alternatives: Return the current list of alternatives
|
||||
;; add-alternative: Add an alternative to the list
|
||||
;;
|
||||
(define (^alternatives bcom question alternatives)
|
||||
(define alts-cell (spawn ^cell alternatives))
|
||||
(methods
|
||||
((question) question)
|
||||
((alternatives) ($ alts-cell 'get))
|
||||
((add alt)
|
||||
($ alts-cell 'set (cons alt ($ alts-cell 'get))))
|
||||
))
|
||||
|
||||
;; Constructor for ^ranked-preference
|
||||
;; One constituent's preferences as an ordered ranking.
|
||||
;;
|
||||
;; Preferences model a single constituent's preference on a specific question.
|
||||
;; Ranked preferenes model constituent preferences as an ordered relationship
|
||||
;; between a finite list of possible alternatives.
|
||||
;;
|
||||
;; ^ranked-preference is associated with a set of alternatives at creation.
|
||||
;; The initial ranking is empty.
|
||||
;;
|
||||
;; Preferences are updated by passing a function mapping alternatives to
|
||||
;; their ranks, which ensures consistency between the alternatives and the
|
||||
;; elements of the ranking.
|
||||
;;
|
||||
;; Parameters:
|
||||
;; alternatives: An ^alternatives object
|
||||
;;
|
||||
;; Messages:
|
||||
;; ranked: Return the ranked list of alternatives
|
||||
;; rank-of alternative: Return the rank of alternative (1 is most
|
||||
;; preferred) or #f if not present in the ranking
|
||||
;; set f: Update the ranking according to a function mapping alternatives
|
||||
;; to their rank position.
|
||||
;;
|
||||
(define (^ranked-preference _bcom alternatives)
|
||||
(define ranking (spawn ^cell '()))
|
||||
(methods
|
||||
((ranked) ($ ranking 'get))
|
||||
((rank-of alternative)
|
||||
(let ((alt-index
|
||||
(list-index
|
||||
(lambda (alt) (equal? alt alternative))
|
||||
($ ranking 'get))))
|
||||
(if (number? alt-index)
|
||||
(+ 1 alt-index)
|
||||
#f)))
|
||||
((set f)
|
||||
(let* ((alt-list ($ alternatives 'alternatives))
|
||||
(ranks (f alt-list))
|
||||
(new-ranking (reorder alt-list ranks)))
|
||||
($ ranking 'set new-ranking)))
|
||||
))
|
||||
|
||||
;; Constructor for ^ranked-profile
|
||||
;; A preference profile for ordered rankings.
|
||||
;;
|
||||
;; Preference profiles represent the preferences of a group of constituents
|
||||
;; on a specific question. Ranked preferences model constituent preferences as
|
||||
;; an ordered relationships between a finite list of possible alternatives.
|
||||
;;
|
||||
;; Parameters:
|
||||
;; alternatives: An ^alternatives object
|
||||
;;
|
||||
;; Messages:
|
||||
;; add-preference: Create and track a new ^ranked-preference as part of this
|
||||
;; profile. The new object is returned.
|
||||
;; counts: Returns a list representing all preference rankings in the
|
||||
;; profile. The list is of the form:
|
||||
;; ((`ranking-1` . `count-1`) (`ranking-2` . `count-2`) ...)
|
||||
;; where `ranking-n` is a list of strings, and `count-n` is the number
|
||||
;; of times that ranking appears in this profile.
|
||||
;;
|
||||
(define (^ranked-profile _bcom alternatives)
|
||||
(define preferences (spawn ^cell '()))
|
||||
(methods
|
||||
((add-preference)
|
||||
(let ((pref (spawn ^ranked-preference alternatives)))
|
||||
($ preferences 'set (cons pref ($ preferences 'get)))
|
||||
pref))
|
||||
((counts)
|
||||
(let ((rankings (map (lambda (pref) ($ pref 'ranked))
|
||||
($ preferences 'get))))
|
||||
;; This is an inefficent represntation but OK for now
|
||||
;; ((<ranking-1> . 1) (<ranking-2> . 1) ...)
|
||||
(map cons rankings (const-list (length rankings) 1))))
|
||||
))
|
||||
|
||||
|
@ -0,0 +1,102 @@
|
||||
;;; 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 (tests test-preference)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (goblins)
|
||||
#:use-module (goblins vrun)
|
||||
#:use-module (goblins actor-lib methods)
|
||||
#:use-module (deliberate preference))
|
||||
|
||||
(test-begin "test-deliberate-preference")
|
||||
|
||||
(define a-vat (spawn-vat))
|
||||
(define-vat-run a-run a-vat)
|
||||
|
||||
;; Tests for ^alternatives
|
||||
(define question "What type of generator should we install?")
|
||||
(define alts (a-run (spawn ^alternatives question '("solar" "wind"))))
|
||||
|
||||
(test-equal "What type of generator should we install?"
|
||||
(a-run ($ alts 'question)))
|
||||
|
||||
(test-equal '("solar" "wind")
|
||||
(a-run ($ alts 'alternatives)))
|
||||
|
||||
(a-run ($ alts 'add "hydro"))
|
||||
|
||||
(test-equal '("hydro" "solar" "wind")
|
||||
(a-run ($ alts 'alternatives)))
|
||||
|
||||
|
||||
;; Tests for ^ranked-preference
|
||||
(define alternatives
|
||||
(a-run (spawn ^alternatives
|
||||
question
|
||||
'("solar" "wind" "hydro"))))
|
||||
(define (f1 alts) '(1 2 3))
|
||||
(define (f2 alts) '(2 3 1))
|
||||
|
||||
(define pref (a-run (spawn ^ranked-preference alternatives)))
|
||||
|
||||
(test-equal '()
|
||||
(a-run ($ pref 'ranked)))
|
||||
|
||||
(test-equal #f
|
||||
(a-run ($ pref 'rank-of "solar")))
|
||||
|
||||
(a-run ($ pref 'set f1))
|
||||
|
||||
(test-equal 1
|
||||
(a-run ($ pref 'rank-of "solar")))
|
||||
|
||||
(test-equal 3
|
||||
(a-run ($ pref 'rank-of "hydro")))
|
||||
|
||||
(test-equal #f
|
||||
(a-run ($ pref 'rank-of "wildgoose")))
|
||||
|
||||
(a-run ($ pref 'set f2))
|
||||
|
||||
(test-equal 1
|
||||
(a-run ($ pref 'rank-of "hydro")))
|
||||
|
||||
|
||||
;; Tests for ^ranked-profile
|
||||
(define profile (a-run (spawn ^ranked-profile alternatives)))
|
||||
(define pref1 (a-run ($ profile 'add-preference)))
|
||||
|
||||
(test-equal '()
|
||||
(a-run ($ pref1 'ranked)))
|
||||
|
||||
(define pref2 (a-run ($ profile 'add-preference)))
|
||||
(a-run ($ pref1 'set f1))
|
||||
(a-run ($ pref2 'set f2))
|
||||
|
||||
(define counts (a-run ($ profile 'counts)))
|
||||
|
||||
(test-equal '((("hydro" "solar" "wind") . 1)
|
||||
(("solar" "wind" "hydro") . 1))
|
||||
counts)
|
||||
|
||||
(test-equal '("hydro" "solar" "wind")
|
||||
(car (car counts)))
|
||||
|
||||
(test-equal 1
|
||||
(cdr (car counts)))
|
||||
|
||||
(test-equal '("solar" "wind" "hydro")
|
||||
(car (cadr counts)))
|
||||
|
||||
(test-end "test-deliberate-preference")
|
Loading…
Reference in New Issue