trial/achievements.lisp at master · Shirakumo/trial · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
(in-package #:org.shirakumo.fraf.trial)

(defvar *achievements* (make-hash-table :test 'eq))

(defmethod achievement ((name symbol))
  (or (gethash name *achievements*)
      (error "No achievement named ~s found." name)))

(defmethod achievement ((name string))
  (loop for achievement being the hash-keys of *achievements*
        for string = (string achievement)
        do (when (and (= (length string) (length name))
                      (loop for a across name
                            for b across string
                            always (or (char-equal a b)
                                       (char= a #\_)
                                       (char= a #\ ))))
             (return (gethash achievement *achievements*)))
        finally (error "No achievement named ~s found." name)))

(defmethod (setf achievement) (achievement (name symbol))
  (setf (gethash name *achievements*) achievement))

(defmethod (setf achievement) ((none null) (name symbol))
  (remhash name *achievements*)
  NIL)

(defun list-achievements ()
  (sort (alexandria:hash-table-values *achievements*) #'string< :key #'name))

(defclass achievement ()
  ((name :initarg :name :accessor name)
   (title :initarg :title :accessor title)
   (description :initarg :description :initform NIL :accessor description)
   (icon :initarg :icon :initform NIL :accessor icon)
   (event-type :initarg :event-type :initform NIL :accessor event-type)
   (test-function :initarg :test-function :initform (constantly NIL) :accessor test-function)
   (active-p :initform NIL :accessor active-p)))

(defmethod print-object ((achievement achievement) stream)
  (print-unreadable-object (achievement stream :type T)
    (format stream "~s ~:[LOCKED~;UNLOCKED~]" (name achievement) (active-p achievement))))

(defmacro define-achievement (name &optional event-type &body test-function)
  (destructuring-bind (name &key (title name) (description (mksym *package* name '/description)) (icon NIL)) (enlist name)
    (destructuring-bind (event-name event-type) (enlist (or event-type '(unused NIL)) event-type)
      `(progn (setf (achievement ',name) (ensure-instance (ignore-errors (achievement ',name)) 'achievement
                                                          :name ',name
                                                          :title ',title
                                                          :description ',description
                                                          :icon ,icon
                                                          :event-type ',event-type
                                                          :test-function (lambda (,event-name)
                                                                           (declare (ignorable ,event-name))
                                                                           ,@test-function)))
              ',name))))

(defmethod title ((achievement achievement))
  (language-string (slot-value achievement 'title)))

(defmethod description ((achievement achievement))
  (language-string (slot-value achievement 'description)))

(define-handler (achievement (ev event)) ()
  (when (and (not (active-p achievement))
             (typep ev (event-type achievement))
             (funcall (test-function achievement) ev))
    (award achievement)))

(defmethod award ((achievement achievement))
  (setf (active-p achievement) T))

(defmethod award ((name symbol))
  (award (achievement name)))

(defmethod (setf active-p) :around (new (achievement achievement))
  (let ((old (active-p achievement)))
    (cond ((and new (not old))
           (v:info :trial.achievements "Unlocked ~a ~s" (name achievement) (title achievement))
           (call-next-method)
           (issue T 'achievement-unlocked :achievement achievement))
          ((and old (not new))
           (v:info :trial.achievements "Relocked ~a ~s" (name achievement) (title achievement))
           (call-next-method)
           (issue T 'achievement-relocked :achievement achievement)))
    new))

(define-event achievement-event () achievement)
(define-event achievement-unlocked (achievement-event))
(define-event achievement-relocked (achievement-event))

(define-global +achievement-api+ NIL)
(defvar *achievement-apis* ())

(defclass achievement-api ()
  ((active-p :initform NIL :accessor active-p)))

(defgeneric load-achievement-data (achievement-api))
(defgeneric notifications-display-p (achievement-api))
(defgeneric (setf notifications-display-p) (value achievement-api))

(define-handler (achievement-api event) ()
  (loop for achievement being the hash-values of *achievements*
        do (handle event achievement)))

(defmethod load-achievement-data ((all (eql T)))
  (dolist (api *achievement-apis*)
    (ignore-errors
     (with-error-logging (:trial.achievements "Failed to load achievement data from ~a" api)
       (load-achievement-data api)
       (return (setf +achievement-api+ api))))))

(defclass local-achievement-api (achievement-api)
  ())

(defun achievement-file-path ()
  (make-pathname :name "achievements" :type "lisp"
                 :defaults (config-directory)))

(defmethod load-achievement-data ((api local-achievement-api))
  (unless (probe-file (achievement-file-path))
    (error "No local achievement data file present."))
  (depot:with-open (tx (achievement-file-path) :input 'character :if-does-not-exist NIL)
    (when tx
      (let ((stream (depot:to-stream tx)))
        (loop for achievement being the hash-values of *achievements*
              do (setf (slot-value achievement 'active-p) NIL))
        (loop for name = (read stream NIL NIL)
              while name
              do (ignore-errors
                  (with-error-logging (:trial.achievements "Failed to find achievement ~a" name)
                    (setf (slot-value (achievement name) 'active-p) T))))))))

(defmethod save-achievement-data ((api local-achievement-api))
  (depot:with-open (tx (achievement-file-path) :output 'character)
    (loop with stream = (depot:to-stream tx)
          for achievement being the hash-values of *achievements*
          do (when (active-p achievement)
               (prin1 (name achievement) stream)
               (terpri stream)))))

(defmethod notifications-display-p ((api local-achievement-api)) NIL)
(defmethod (setf notifications-display-p) (value (api local-achievement-api)) NIL)

(define-handler (local-achievement-api achievement-event :after) ()
  (save-achievement-data local-achievement-api))

(pushnew (make-instance 'local-achievement-api) *achievement-apis*)