Browse Source

Initial commit.

master
isoraqathedh 1 year ago
commit
db4488b23d
7 changed files with 609 additions and 0 deletions
  1. +101
    -0
      bodies.lisp
  2. +273
    -0
      body-definitions.lisp
  3. +11
    -0
      bugscript.asd
  4. +59
    -0
      bugscript.lisp
  5. +80
    -0
      canvas.lisp
  6. +6
    -0
      package.lisp
  7. +79
    -0
      tests.lisp

+ 101
- 0
bodies.lisp View File

@ -0,0 +1,101 @@
;;;; bodies.lisp
(in-package #:bugscript)
;;; General body stuff
(defclass figure ()
())
;;; Body
(defclass body (figure)
((width :accessor width :initarg :width)
(accessories :accessor accessories :initarg :accessories))
(:default-initargs
:width nil
:accessories ()))
(defclass reversible ()
((invertedp :accessor invertedp :initarg :invertedp :initform nil))
(:documentation "Mixin for bodies that are not horizontally symmetric."))
(defclass vertically-symmetric ()
()
(:documentation "Mixin for bodies that ARE vertically symmetric."))
(defmethod draw-on-artist ((element null) props shape))
(defmethod draw-on-artist :around (element props (shape vertically-symmetric))
(call-next-method)
(svg:transform ((svg:scale 1 -1))
(call-next-method)))
(defgeneric bonding-point (body height))
(defgeneric register-body (artist body)
(:method ((artist bugscript-artist) (body body))
(push body (elements artist))))
(defmethod pre-movement ((artist bugscript-artist) (figure figure)))
(defmethod post-movement ((artist bugscript-artist) (figure figure)))
(defmacro do-elements ((var artist) &body body)
`(dolist (,var (reverse (elements ,artist)))
,@body))
(defgeneric make-body-group (canva))
;;; Accessories
(defclass accessory (figure) ())
(defgeneric register-accessory (body accessory)
(:method ((body body) (accessory accessory))
(push accessory (accessories body))))
(defmacro insert-body ((artist body-var body-type &rest body-initargs)
&body accessories)
artist body-var body-type body-initargs accessories
;; temporary
nil)
(defmacro insert-accessory ((artist body) accessory-type &rest initargs)
artist body accessory-type initargs
;; temporary
nil)
(defmacro do-accessories ((var bug-body) &body body)
`(dolist (,var (reverse (accessories ,bug-body)))
,@body))
(defmacro do-accessories* ((var bug-body) &body body)
`(dolist (,var (cons ,bug-body (reverse (accessories ,bug-body))))
,@body))
;;; Drawing
(defgeneric compute-transformation (artist body)
(:method ((artist bugscript-artist) (body body))
(transform-string (svg:translate (cursor artist) (centreline artist))))
(:method ((artist bugscript-artist) (body reversible))
(transform-string (call-next-method)
(if (invertedp bod)y
(svg:scale -1 1)
""))))
(defmethod draw (scene (artist bugscript-artist) (shape body))
(do-accessories* (i shape)
(pre-movement artist i))
(let ((gp (create-body-group scene (compute-transformation artist shape))))
(do-accessories* (i shape)
(draw-on-artist gp artist i)))
(do-accessories* (i shape)
(post-movement artist i)))
(defmethod draw (scene (artist bugscript-artist) (shape reversible))
(if (invertedp shape)
(progn
(do-accessories* (i shape)
(post-movement artist i))
(let ((gp (create-body-group scene (compute-transformation artist shape))))
(do-accessories* (i shape)
(draw-on-artist gp artist i)))
(do-accessories* (i shape)
(pre-movement artist i)))
(call-next-method)))

+ 273
- 0
body-definitions.lisp View File

@ -0,0 +1,273 @@
;;;; body-definitions.lisp
(in-package #:bugscript)
;;; ;;;;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BODIES ;;;
;;; ;;;;;; ;;;
;;; ===== ===== ===== Blackball
(defclass blackball (body) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape blackball))
(svg:draw artist (:circle :cx 0 :cy 0 :r (u-size props 2/3))))
(defmethod pre-movement ((artist bugscript-artist) (figure blackball))
(advance-cursor artist (u-size artist 1/3)))
(defmethod post-movement ((artist bugscript-artist) (figure blackball))
(advance-cursor artist (u-size artist 1/3)))
;;; ===== ===== ===== Round body
(defclass round-body (reversible body) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape round-body))
(svg:draw artist (:path :d (svg:path
(svg:move-to 0 0)
(semicircle-to 0 0 (u-size props 1) 0 180)
(svg:close-path)))
:stroke-width (stroke props)
:stroke "black"
:fill "none"))
(defmethod pre-movement ((artist bugscript-artist) (figure round-body))
(advance-cursor artist (u-size artist 1)))
;;; ===== ===== ===== Vowel body
(defclass vowel-body (body) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape vowel-body))
(svg:draw artist (:rect :x 0 :y (u-size props -1)
:width (u-size props 2/5) :height (u-size props 2))
:stroke-width (stroke props)
:stroke "black"
:fill "none"))
(defmethod post-movement ((artist bugscript-artist) (figure vowel-body))
(advance-cursor artist (u-size artist 2/5)))
;;; ===== ===== ===== Approximant body
(defclass approximant-body (reversible body) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape approximant-body))
(svg:draw artist (:path :d (svg:path
(svg:move-to 0 (u-size props 1))
(svg:line-to (u-size props -1/2) (u-size props 1/2))
(svg:line-to (u-size props -1/2) (u-size props -1/2))
(svg:line-to 0 (u-size props -1))
(svg:close-path))
:stroke-width (stroke props)
:stroke "black"
:fill "none")))
(defmethod pre-movement ((artist bugscript-artist) (figure approximant-body))
(advance-cursor artist (u-size artist 1/2)))
;;; ===== ===== ===== Non-pulmonic body
(defclass nonpulmonic-body (reversible body) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape nonpulmonic-body))
(svg:draw artist (:path :d (svg:path
(svg:move-to 0 (u-size props 1))
(svg:line-to (u-size props -1) 0)
(svg:line-to 0 (u-size props -1))
(svg:close-path)))
:stroke-width (stroke props)
:stroke "black"
:fill "none"))
(defmethod pre-movement ((artist bugscript-artist) (figure nonpulmonic-body))
(advance-cursor artist (u-size artist 1)))
;;; ===== ===== ===== Spacer
(defclass spacer (body)
((space-width :reader space-width
:initarg :space-width
:initform 3)))
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape spacer)))
(defmethod pre-movement ((artist bugscript-artist) (figure spacer))
(advance-cursor artist (u-size artist (space-width figure))))
;;; ;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ACCESSORIES ;;;
;;; ;;;;;;;;;;; ;;;
;;; ===== ===== ===== Plosive circles
(defclass plosive-circle (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape plosive-circle))
(svg:draw artist (:circle :cx (u-size props -3/4) :cy 0
:r (stroke props))
:fill "black"))
;;; ===== ===== ===== Fricative stripes
(defclass fricative-stripe (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape fricative-stripe))
(let* ((common-y (u-size props 3/8))
(bonding-point -38)) ; need adjusting to fit all sizes
(svg:draw artist (:line :x1 bonding-point
:y1 common-y
:x2 0
:y2 common-y)
:stroke-width (stroke props)
:stroke "black"
:fill "none")
(svg:draw artist (:line :x1 bonding-point
:y1 (- common-y)
:x2 0
:y2 (- common-y))
:stroke-width (stroke props)
:stroke "black"
:fill "none")))
;;; ===== ===== ===== Sibilant feelers
(defclass sibilant-feelers (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape sibilant-feelers))
(let* ((r 1/10)
(bonding-point -38)) ; need adjusting to fit all sizes
(svg:draw artist (:path :d (let ((cumu-x 0) (cumu-y 1/4))
(svg:path
(svg:move-to bonding-point (u-size props cumu-y))
(svg:line-to (- bonding-point
(u-size props (incf cumu-x 3/10)))
(u-size props (incf cumu-y 3/10)))
(semicircle-to (- bonding-point
(u-size props (+ r cumu-x 1/20)))
(u-size props cumu-y)
(u-size props r)
90
274
:draw-to)))
:stroke-width) (stroke props)
:stroke "black"
:fill "none")
(svg:draw artist (:path :d (svg:path
(semicircle-to (- bonding-point
(u-size props (+ 3/10 1/5)))
(u-size props (+ -1/4 -3/10))
(u-size props r)
274
90)
(svg:line-to (- bonding-point
(u-size props (+ 3/10 1/20)))
(u-size props (+ -1/4 -3/10)))
(svg:line-to bonding-point (u-size props -1/4))))
:stroke-width (stroke props)
:stroke "black"
:fill "none")))
(defmethod pre-movement ((artist bugscript-artist) (figure sibilant-feelers))
(advance-cursor artist (u-size artist (+ 3/10 1/5))))
;;; ===== ===== ===== Labial feelers
(defclass labial-feelers (accessory)
((feeler-length :accessor feeler-length
:initarg :feeler-length
:initform 1/2)))
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape labial-feelers))
(let* ((common-y (u-size props 1/8))
(feeler-length (u-size props (feeler-length shape)))
(bonding-point -40)) ; need adjusting to fit all sizes
(svg:draw artist (:line :x1 bonding-point
:y1 common-y
:x2 (- bonding-point feeler-length)
:y2 common-y)
:stroke-width (stroke props)
:stroke "black"
:fill "none")
(svg:draw artist (:line :x1 bonding-point
:y1 (- common-y)
:x2 (- bonding-point feeler-length)
:y2 (- common-y))
:stroke-width (stroke props)
:stroke "black"
:fill "none")))
(defmethod pre-movement ((artist bugscript-artist) (figure labial-feelers))
(advance-cursor artist (u-size artist (feeler-length figure))))
;;; ===== ===== ===== Velar feelers
(defclass velar-feelers (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape velar-feelers))
(svg:draw artist (:line :x1 0 :y1 (u-size props -1)
:x2 (u-size props -1/8) :y2 (u-size props -9/8))
:stroke-width (stroke props)
:stroke "black"
:fill "none")
(svg:draw artist (:line :x1 0 :y1 (u-size props 1)
:x2 (u-size props -1/8) :y2 (u-size props 9/8))
:stroke-width (stroke props)
:stroke "black"
:fill "none"))
;;; ===== ===== ===== Voicing circle
(defclass voicing-hollow-circle (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape voicing-hollow-circle))
(svg:draw artist (:circle :cx (u-size props -1/2) :cy 0
:r (stroke props))
:fill "none"
:stroke "black"
:stroke-width 2))
;;; ===== ===== ===== Back-unrounded-vowel stripe
(defclass back-unrounded-vowel (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape back-unrounded-vowel))
(svg:draw artist (:rect :x (u-size props 1/5) :y (u-size props -1/2)
:width (u-size props 1/5) :height (u-size props 1))
:fill "black"))
;;; ===== ===== ===== front-close-unrounded-vowel stripe
(defclass front-close-unrounded-vowel (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape front-close-unrounded-vowel))
(svg:draw artist (:path :d (svg:path
(svg:move-to (u-size props 2/5) (u-size props -1))
(svg:line-to 0 (u-size props -3/5))
(svg:line-to 0 (u-size props -1))
(svg:close-path)))
:fill "black"))
;;; ===== ===== ===== front-close-lax-unrounded-vowel stripe
(defclass front-close-lax-unrounded-vowel (accessory) ())
(defmethod draw-on-artist ((artist svg::svg-element)
(props bugscript-artist)
(shape front-close-lax-unrounded-vowel))
(svg:draw artist (:rect :x 0 :y (u-size props -1)
:width (u-size props 1/5) :height (u-size props 4/5))
:fill "black"))

+ 11
- 0
bugscript.asd View File

@ -0,0 +1,11 @@
(asdf:defsystem #:bugscript
:description "Library for describing and drawing bugscript."
:author "Isoraķatheð Zorethan <[email protected]>"
:license "MIT"
:version "0.0.1"
:serial t
:depends-on (#:cl-svg)
:components ((:file "package")
(:file "canvas")
(:file "bodies")
(:file "body-definitions")))

+ 59
- 0
bugscript.lisp View File

@ -0,0 +1,59 @@
;;;; bugscript.lisp
(in-package #:bugscript)
(defparameter *here* (asdf:system-relative-pathname 'bugscript nil)
"The default directory where things are dumped.")
(defun dump-to-file (scene filename &optional (default-pathname *here*))
(let ((*default-pathname-defaults* default-pathname))
(with-open-file (s filename :direction :output :if-exists :supersede)
(cl-svg:stream-out s scene))))
;;; Drawings
(defvar *centre-line*)
(defvar *reference-height*)
(defun polar-to-cartesian (cx cy radius degrees)
(let ((radians (* (- degrees 90) pi 1/180)))
(cons (+ cx (* radius (cos radians)))
(+ cy (* radius (sin radians))))))
(defun semicircle-to (cx cy radius start-angle end-angle &optional draw-to)
(destructuring-bind (sx . sy) (polar-to-cartesian cx cy radius start-angle)
(destructuring-bind (ex . ey) (polar-to-cartesian cx cy radius end-angle)
(svg:path
(if draw-to
(svg:line-to sx sy)
(svg:move-to sx sy))
(svg:arc-to radius radius
0 (if (<= (- start-angle end-angle) 180) 0 1) 0
ex ey)))))
;;; Test thing.
(let ((a (make-instance 'bugscript-artist :output-filename "test"
:margin 20
:stroke 3
:height 40)))
(let ((b (make-instance 'round-body)))
(register-accessory b (make-instance 'double-front))
(register-accessory b (make-instance 'voicing-hollow-circle))
(register-accessory b (make-instance 'plosive-filled-circle))
(register-body a b))
(let ((b (make-instance 'vowel-body)))
(register-accessory b (make-instance 'back-mid-filled))
(register-body a b))
(let ((b (make-instance 'round-body :invertedp t)))
(register-accessory b (make-instance 'back-fin))
(register-accessory b (make-instance 'voicing-hollow-circle))
(register-accessory b (make-instance 'plosive-filled-circle))
(register-body a b))
(let ((b (make-instance 'nonpulmonic-body :invertedp t)))
(register-body a b))
(dump-svg-file a))
(defun transform-string (&rest transformation-specs)
"Combine multiple transformation strings together."
(format nil "~{~a~^ ~}" transformation-specs))
;; separated drawing code

+ 80
- 0
canvas.lisp View File

@ -0,0 +1,80 @@
;;;; canvas.lisp
(in-package #:bugscript)
;;; The artist
(defclass bugscript-artist ()
((cursor :accessor cursor :initarg :cursor)
(height :accessor height :initarg :height)
(stroke :accessor stroke :initarg :stroke)
(margin :accessor margin :initarg :margin)
(elements :accessor elements :initform ())
(outfile :accessor outfile))
(:default-initargs
:height 80
:cursor 0
:margin 20
:stroke 3))
(defgeneric advance-cursor (artist value)
(:method ((artist bugscript-artist) (value number))
(incf (cursor artist) value)))
(defmethod initialize-instance :after ((artist bugscript-artist)
&key output-filename &allow-other-keys)
(advance-cursor artist (margin artist))
(setf (outfile artist) (make-pathname :name output-filename :type "svg"
:defaults *here*)))
(defgeneric u-size (artist frac)
(:method ((artist bugscript-artist) (frac number))
(* (height artist) frac)))
;;; Adding content
(defgeneric width (object))
(defgeneric fiduciary-width (artist)
(:method ((artist bugscript-artist))
(reduce #'+ (elements artist) :key #'width)))
(defgeneric total-height (artist)
(:method ((artist bugscript-artist))
(u-size artist 6)))
(defgeneric centreline (artist)
(:method ((artist bugscript-artist))
(/ (total-height artist) 2)))
;;; Finishing up
(defgeneric draw (scene artist shape)
(:documentation "The complete drawing code, complete with cursor movements."))
(defgeneric draw-on-artist (element props shape)
(:documentation "Draw SHAPE on ELEMENT with PROPS.
This should not move the cursor in response to general spacing."))
(defgeneric pre-movement (artist figure))
(defgeneric post-movement (artist figure))
(defun create-body-group (scene &optional (transform-string ""))
(when scene
(svg:make-group scene (:id (symbol-name (gensym "PHONEME"))
:transform transform-string))))
(defun make-bodies (artist &rest bodies)
"Create BODIES on ARTIST.
BODIES create the list of bodies, in order. Each body is of the form:
\((body-class &rest body-initargs)
(accessories &rest accessory-initargs) ...\),
where the latter can be repeated for as many times as needed.
A raw symbol may be substituted for each of the inner lists
if no initargs are needed."
(dolist (bodydef bodies)
(destructuring-bind (body &rest accessories) bodydef
(let ((b (apply #'make-instance (alexandria:ensure-list body))))
(dolist (i accessories)
(register-accessory b (apply #'make-instance
(alexandria:ensure-list i))))
(register-body artist b)))))

+ 6
- 0
package.lisp View File

@ -0,0 +1,6 @@
;;;; package
(defpackage #:info.isoraqathedh.bugscript
(:use #:cl)
(:nicknames #:bugscript)
(:import-from #:cl-svg
#:svg-1.1-toplevel))

+ 79
- 0
tests.lisp View File

@ -0,0 +1,79 @@
(in-package #:bugscript)
(defun test-1 ()
(let ((a (make-instance 'bugscript-artist
:output-filename "test1"
:margin 10
:height 40
:stroke 3)))
(make-bodies
a
;; ===== ===== ===== ===== /b/ ===== ===== ===== ===== ;;
'(round-body
plosive-circle voicing-hollow-circle labial-feelers)
;; ===== ===== ===== ===== /V/ ===== ===== ===== ===== ;;
'(vowel-body
back-unrounded-vowel)
;; ===== ===== ===== ===== /g/ ===== ===== ===== ===== ;;
'((round-body :invertedp t)
plosive-circle voicing-hollow-circle velar-feelers)
;; ===== ===== ===== Spacer ===== ===== ===== ;;
'((spacer :space-width 2))
;; '(blackball)
;; '((spacer :space-width 2))
;; ===== ===== ===== ===== /s/ ===== ===== ===== ===== ;;
'(round-body
fricative-stripe sibilant-feelers)
;; ===== ===== ===== ===== /k/ ===== ===== ===== ===== ;;
'(round-body
plosive-circle velar-feelers)
;; ===== ===== ===== ===== /r\/ ===== ===== ===== ===== ;;
'(approximant-body)
;; ===== ===== ===== ===== /I/ ===== ===== ===== ===== ;;
'(vowel-body
front-close-lax-unrounded-vowel)
;; ===== ===== ===== ===== /p/ ===== ===== ===== ===== ;;
'((round-body :invertedp t)
plosive-circle
(labial-feelers :feeler-length 1/5))
;; ===== ===== ===== ===== /t/ ===== ===== ===== ===== ;;
'((round-body :invertedp t)
plosive-circle sibilant-feelers)
;; ===== ===== ===== Spacer ===== ===== ===== ;;
'((spacer :space-width 2))
'(nonpulmonic-body)
'((spacer :space-width 1/2))
'((nonpulmonic-body :invertedp t)))
(with-accessors ((cursor cursor)
(stroke stroke)
(height height)
(margin margin)
(centreline centreline)) a
;; ===== ===== ===== WIDTH SIMULATION ===== ===== ===== ;;
(do-elements (element a)
(draw nil a element))
;; ===== ===== ===== ACTUAL DRAWING ===== ===== ===== ;;
(svg:with-svg-to-file
(s 'svg-1.1-toplevel :height (total-height a)
:width (+ cursor (* 2 margin)))
((make-pathname :defaults *here* :name "test" :type "svg")
:if-exists :supersede
:external-format :utf-8)
(setf cursor margin)
(do-elements (element a)
(draw s a element))))))

Loading…
Cancel
Save