Skip to content

Instantly share code, notes, and snippets.

@sgithens

sgithens/htmlexport.lisp

Created February 4, 2021 22:08
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save sgithens/aa415c19df13a8f36f258d405481eec0 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save sgithens/aa415c19df13a8f36f258d405481eec0 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
htmlexport.lisp
;;;;
;;;; Boxer
;;;; Copyright 1985-2020 Andrea A. diSessa and the Estate of Edward H. Lay
;;;;
;;;; Portions of this code may be copyright 1982-1985 Massachusetts Institute of Technology. Those portions may be
;;;; used for any purpose, including commercial ones, providing that notice of MIT copyright is retained.
;;;;
;;;; Licensed under the 3-Clause BSD license. You may not use this file except in compliance with this license.
;;;;
;;;; https://opensource.org/licenses/BSD-3-Clause
;;;;
;;;;
;;;; +-Data--+
;;;; This file is part of the | BOXER | system
;;;; +-------+
;;;;
;;;; Full HTML Export - New HTML Export for 2021 that contains a full copy of all data
;;;; in the boxer structures, as well as flexible CSS classes and some
;;;; minimal javascript interaction.
;;;;
;;;; TODO: Add in a general utility for espacping strings for special purpose HTML Characters
(in-package :boxer)
(defclass full-html-file-class
(foreign-file-class)
())
(defmethod begin-foreign-stream ((ffc full-html-file-class)
&optional (stream *standard-output*))
(format stream "<html><head>
<style>
.box legend {
border: thin solid gray;
background-color: white;
}
.box {
border: thin black solid;
width: max-content;
display: inline;
vertical-align: top;
padding-top: 0px;
padding-bottom: 5px;
padding-left: 8px;
overflow: auto;
}
.box.boxtop-name-only {
background-color: white;
border: none;
}
.databox {
border-radius: 10px;
}
.doitbox {
}
.graphicsbox {
border-radius: 10px;
}
.portbox {
border-style: double;
border-width: 6;
}
.export-all-variables {
border-style: dashed;
}
.shrunk {
background-color: gray;
}
.box.supershrunk legend {
display: none;
}
.box.supershrunk {
border-radius: 0px;
background-color: black;
width: 10px;
height: 10px;
margin: 0px;
padding: 0px;
}
</style>
</head><body>"))
(defmethod write-foreign-file-header ((ffc full-html-file-class)
box
&optional (stream *standard-output*)))
(defun get-rgba-values-from-pixmap-pixel (pixel)
(list (ldb opengl::*gl-rgba-rev-red-byte* pixel)
(ldb opengl::*gl-rgba-rev-green-byte* pixel)
(ldb opengl::*gl-rgba-rev-blue-byte* pixel)
(ldb opengl::*gl-rgba-rev-alpha-byte* pixel)))
(defun generate-png-from-ogl-pixmap (pixmap)
(let* ((width (opengl::ogl-pixmap-width pixmap))
(height (opengl::ogl-pixmap-height pixmap))
(data (opengl::ogl-pixmap-data pixmap))
(cur-pixel nil)
(png (make-instance 'zpng:pixel-streamed-png
:color-type :truecolor-alpha
:width width
:height height))
(togo nil))
(with-output-to-string (s)
(with-open-stream (stream (make-instance 'qbase64:encode-stream :underlying-stream s))
(zpng:start-png png stream)
(dotimes (y height)
(dotimes (x width)
(setf cur-pixel (fli::dereference data :index (+ x (* (- height y 1) width))))
(zpng:write-pixel (get-rgba-values-from-pixmap-pixel cur-pixel) png)))
(zpng:finish-png png))
(setf togo (get-output-stream-string s)))
(print "What is togo?")
(print togo)
togo))
(defmethod write-foreign-file-box ((ffc full-html-file-class) box stream)
(let* ((*export-properties* (merge-export-properties
*export-properties*
(get-export-format-properties box)))
(nr (name-row box))
(graphics-mode? (display-style-graphics-mode? (display-style-list box)))
(fixed-wid (display-style-fixed-wid (display-style-list box)))
(fixed-hei (display-style-fixed-hei (display-style-list box)))
(d-style (display-style-style (display-style-list box))) ; :normal :shrunk :supershrunk :boxtop
(css-classes '("box")))
;; Box type css class
(push (symbol-name (symbol-from-box-type box)) css-classes)
;; Box shurnk status style
(push (symbol-name d-style) css-classes)
(if (and (equal d-style :shrunk) (equal :NAME-ONLY (getf (plist box) :BOXTOP)))
(push "boxtop-name-only" css-classes))
;; Optional export variables css class
(if (slot-value box 'exports)
;; Are there any other exports than .EXPORT-ALL-VARIABLES. ?
(push "export-all-variables" css-classes))
(if (and fixed-wid fixed-hei)
(format stream "<fieldset style=\"width: ~f; height: ~f;\" id=\"tick-~a\" class=\"~{~a ~}\">" fixed-wid fixed-hei (actual-obj-tick box) css-classes)
(format stream "<fieldset id=\"tick-~a\" class=\"~{~a ~}\">" (actual-obj-tick box) css-classes))
;; Name row
(format stream "<legend>~a</legend>" (get-export-namerow-string box))
(when (and (not graphics-mode?) (equal d-style :normal))
(do ((row (first-inferior-row box) (next-row row)))
((null row))
(write-foreign-file-row ffc row stream)
(if (next-row row)
(format stream "<br/>"))))
;; if it's a graphics box, let's create the canvas
(when (and (graphics-box? box) graphics-mode? (equal d-style :normal))
(let* ((gs (graphics-info box))
(width (graphics-sheet-draw-wid gs))
(height (graphics-sheet-draw-hei gs))
(bit-array-dirty? (graphics-sheet-bit-array-dirty? gs))
(background-color (if (graphics-sheet-background gs)
(ogl-color-to-css-hex (graphics-sheet-background gs))
(ogl-color-to-css-hex *white*)))
(glist (graphics-sheet-graphics-list gs))
(glist-commands (aref glist 0))
(gobj-list (graphics-sheet-object-list gs))
(current-pen-color (ogl-color-to-css-hex *black*)))
(format stream "<svg width=\"~a\" height=\"~a\" xmlns=\"http://www.w3.org/2000/svg\">" width height )
(if bit-array-dirty?
(let ((base64png (generate-png-from-ogl-pixmap (graphics-sheet-bit-array gs))))
(print "Shit what is it for real?")
(print base64png)
(format stream "<image href=\"data:image/png;base64,~a\"/>" base64png))
(format stream "<rect width=\"100%\" height=\"100%\" fill=\"~a\"/>" background-color))
(loop for command across (remove nil glist-commands)
do
(progn
(cond ((equal (aref command 0) 3) ; draw-line
(format stream "<line x1=\"~a\" y1=\"~a\" x2=\"~a\" y2=\"~a\" stroke=\"~a\" />"
(aref command 1) (aref command 2) (aref command 3) (aref command 4) current-pen-color))
((equal (aref command 0) 4) ; change-graphics-color
(setf current-pen-color (ogl-color-to-css-hex (aref command 1))))
((equal (aref command 0) 7) ; centered-string
(format stream "<text x=\"~f\" y=\"~f\" dominant-baseline=\"hanging\" text-anchor=\"middle\">~a</text>"
(aref command 1) (aref command 2) (aref command 3)))
((equal (aref command 0) 10) ; centered-rectangle
(let* ((width (aref command 3))
(height (aref command 4))
(x (- (aref command 1) (/ width 2)))
(y (- (aref command 2) (/ height 2))))
(format stream "<rect x=\"~f\" y=\"~f\" width=\"~f\" height=\"~f\" fill=\"~a\"/>"
x y width height current-pen-color)))
(t
(format t "~%HTML Need to Implement Graphics command: ~a" command)))))
(if gobj-list
(loop for object in (remove nil gobj-list)
do
(loop for command across (remove nil (aref (slot-value object 'window-shape) 0))
do (cond ((equal (aref command 0) 3)
(format stream "<line x1=\"~a\" y1=\"~a\" x2=\"~a\" y2=\"~a\" stroke=\"black\" />"
(aref command 1) (aref command 2) (aref command 3) (aref command 4)))
(t nil)))
))
(format stream "</svg>")
))
(format stream "</fieldset>")
))
(defun ogl-color-to-css-hex (color)
"Converts one of our internal opengl colors to a hex representation like #ABCC00 thats
ready to go into some html or css"
(let* ((red (floor (* 255 (bw::ogl-color-red color))))
(green (floor (* 255 (bw::ogl-color-green color))))
(blue (floor (* 255 (bw::ogl-color-blue color))))
(alpha (bw::ogl-color-alpha color)))
(format nil "#~2,'0x~2,'0x~2,'0x" red green blue)
))
(defmethod write-foreign-file-row ((ffc full-html-file-class) row stream)
(let* ((bfd-list (aref (chas-array row) 3))
(cur-bfd (car bfd-list))
(cur-color (if cur-bfd
(bfd-color cur-bfd)
*foreground-color*))
(cur-css-color (ogl-color-to-css-hex cur-color))
)
(do-row-chas ((cha row) (cha-no 0 (+ cha-no 1)))
(format t "~%On cha#: ~a cur-bfd: ~a" cha-no cur-bfd)
(when (and cur-bfd (equal cha-no (bfd-cha-no cur-bfd)))
(format t "~% Updating color: cha-no: ~a cur-bfd: ~a" cha-no cur-bfd)
(setf cur-color (bfd-color cur-bfd))
(setf cur-css-color (ogl-color-to-css-hex cur-color))
(when (cdr bfd-list)
(setf cur-bfd (cadr bfd-list))
(setf bfd-list (cdr bfd-list))))
(format t "~%Current colors R:~a G:~a B:~a A:~a " (bw::ogl-color-red cur-color)
(bw::ogl-color-green cur-color) (bw::ogl-color-blue cur-color) (bw::ogl-color-alpha cur-color))
(cond ((box? cha)
(write-foreign-file-box ffc cha stream))
(t
(format stream "<span style=\"color: ~a\">~a</span>" cur-css-color cha) ;; TODO: escape HTML chars
)))))
(defmethod end-foreign-stream ((ffc full-html-file-class)
&optional (stream *standard-output*))
(format stream "</body></html>"))
(def-export-type full-html-file-class "HTML5" "*.html" :respect-line-breaks t)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment