-
-
Notifications
You must be signed in to change notification settings - Fork 46
/
serialize.lisp
148 lines (128 loc) · 5.57 KB
/
serialize.lisp
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)
(define-global +type-serialize-info+ (make-hash-table :test 'eql))
(defun serialize-info (type)
(gethash type +type-serialize-info+))
(defstruct (serialize-info
(:constructor make-serialize-info (type id reader writer)))
(type NIL :type symbol)
(id 0 :type (unsigned-byte 16))
(reader NIL :type (function (stream) T))
(writer NIL :type (function (T stream) T)))
(defmacro define-type-serializer (type reader writer)
`(let ((struct (or (gethash ',type +type-serialize-info+))))
(unless struct
(setf (gethash ',type +type-serialize-info+)
(make-serialize-info ',type (hash-table-count +type-serialize-info+)
(lambda (s) (declare (ignore s)))
(lambda (v s) (declare (ignore v s)))))
(setf struct (gethash ',type +type-serialize-info+))
(setf (gethash (serialize-info-id struct) +type-serialize-info+) struct))
(setf (serialize-info-reader struct) ,reader)
(setf (serialize-info-writer struct) ,writer)
',type))
(defmacro define-object-type-serializer (type constructor &body slots)
`(define-type-serializer ,type
(lambda (stream)
(,constructor ,@(loop for (slot type) in slots
collect (kw slot)
collect `(funcall (load-time-value (serialize-info-reader (gethash ',type +type-serialize-info+))) stream))))
(lambda (event stream)
,@(loop for (slot type) in slots
collect `(funcall (load-time-value (serialize-info-writer (gethash ',type +type-serialize-info+))) (,slot event) stream)))))
(defun serialize-as (type value stream)
(let ((struct (gethash type +type-serialize-info+)))
(funcall (serialize-info-writer struct) value stream)))
(defun deserialize-as (type stream)
(let ((struct (gethash type +type-serialize-info+)))
(funcall (serialize-info-reader struct) stream)))
(define-type-serializer integer
#'nibbles:read-sb64/le
#'nibbles:write-sb64/le)
(define-type-serializer single-float
#'nibbles:read-ieee-single/le
#'nibbles:write-ieee-single/le)
(define-type-serializer double-float
#'nibbles:read-ieee-double/le
#'nibbles:write-ieee-double/le)
(define-type-serializer vec2
(lambda (s) (vec2 (nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)))
(lambda (v s)
(nibbles:write-ieee-single/le (vx2 v) s)
(nibbles:write-ieee-single/le (vy2 v) s)))
(define-type-serializer vec3
(lambda (s) (vec3 (nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)))
(lambda (v s)
(nibbles:write-ieee-single/le (vx3 v) s)
(nibbles:write-ieee-single/le (vy3 v) s)
(nibbles:write-ieee-single/le (vz3 v) s)))
(define-type-serializer vec4
(lambda (s) (vec4 (nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)
(nibbles:read-ieee-single/le s)))
(lambda (v s)
(nibbles:write-ieee-single/le (vx4 v) s)
(nibbles:write-ieee-single/le (vy4 v) s)
(nibbles:write-ieee-single/le (vz4 v) s)
(nibbles:write-ieee-single/le (vw4 v) s)))
(define-type-serializer null
(lambda (s) (declare (ignore s)) NIL)
(lambda (v s) (declare (ignore v s)) NIL))
(define-type-serializer gamepad:device
;; FIXME: Try to restore a more accurate representation of the used device.
(lambda (s)
(declare (ignore s))
(or (block NIL (gamepad:call-with-devices (lambda (d) (return d))))
(load-time-value (allocate-instance (find-class 'gamepad:device)))))
(lambda (v s)
(declare (ignore v s))
NIL))
(define-type-serializer symbol
(lambda (s)
(let ((pkg (make-string (read-byte s) :element-type 'base-char))
(sym (make-string (read-byte s) :element-type 'base-char)))
(dotimes (i (length pkg))
(setf (char pkg i) (code-char (read-byte s))))
(dotimes (i (length sym))
(setf (char sym i) (code-char (read-byte s))))
(intern sym pkg)))
(lambda (v s)
(let ((pkg (package-name (symbol-package v)))
(sym (symbol-name v)))
(write-byte (length pkg) s)
(write-byte (length sym) s)
(loop for char across pkg do (write-byte (char-code char) s))
(loop for char across sym do (write-byte (char-code char) s)))))
(define-type-serializer keyword
(lambda (s)
(let ((sym (make-string (read-byte s) :element-type 'base-char)))
(dotimes (i (length sym))
(setf (char sym i) (code-char (read-byte s))))
(intern sym "KEYWORD")))
(lambda (v s)
(let ((sym (symbol-name v)))
(write-byte (length sym) s)
(loop for char across sym do (write-byte (char-code char) s)))))
(define-type-serializer boolean
(lambda (s)
(< 0 (read-byte s)))
(lambda (v s)
(write-byte (if v 1 0) s)))
(define-type-serializer string
(lambda (s)
(let ((string (make-string (nibbles:read-ub32/le s))))
(dotimes (i (length string) string)
(setf (char string i) (code-char (nibbles:read-ub32/le s))))))
(lambda (v s)
(nibbles:write-ub32/le (length v) s)
(loop for char across v do (nibbles:write-ub32/le (char-code char) s))))
(define-type-serializer T
(lambda (s)
(funcall (serialize-info-reader (gethash (read-byte s) +type-serialize-info+)) s))
(lambda (v s)
(let ((struct (gethash (type-of v) +type-serialize-info+)))
(write-byte (serialize-info-id struct) s)
(funcall (serialize-info-writer struct) v s))))