Coverage report: /home/ellis/comp/core/std/fmt.lisp

Kind	Covered	All	%
expression	16	978	1.6
branch	0	52	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/fmt.lisp --- printer and format utils

2

3

;;; Code:

4

(in-package :std/fmt)

5

6

(defun iprintln (x &optional (n 2) stream)

7

"Print object X with indentation N to stream followed by a new line."

8

(println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream))

9

10

(defun fmt-row (data &optional stream)

11

"Format DATA as a table row to STREAM."

12

(format stream "| ~{~A~^ | ~} |~%" data))

13

14

(defun printer-status ()

15

"Return the current printer status."

16

(macrolet ((fmt (var) `(list ',var ,var)))

17

(pprint-tabulary

18

t

19

(list

20

(fmt *print-array*)

21

(fmt *print-base*)

22

(fmt *print-case*)

23

(fmt *print-circle*)

24

(fmt *print-escape*)

25

(fmt *print-gensym*)

26

(fmt *print-length*)

27

(fmt *print-level*)

28

(fmt *print-lines*)

29

(fmt *print-miser-width*)

30

(fmt *print-pprint-dispatch*)

31

(fmt *print-pretty*)

32

(fmt *print-radix*)

33

(fmt *print-readably*)

34

(fmt *print-right-margin*)))))

35

36

(defun format-sxhash (code &optional stream)

37

"Turn the fixnum value CODE into a human-friendly string. CODE should

38

be produced by `sxhash'."

39

(let (r)

40

(dotimes (i 8 r)

41

(push (ldb (byte 8 (* i 8)) code) r))

42

(format

43

stream

44

"~{~A~^-~}"

45

(mapcar

46

(lambda (x) (format nil "~{~(~2,'0x~)~}" x))

47

(group r 2)))))

48

49

;;; Trees

50

51

;; from https://gist.github.com/WetHat/9682b8f70f0241c37cd5d732784d1577

52

53

;; Example:

54

55

;; (let ((tree '(A B1 B2 (B3 C1) C2)))

56

;; ; enumerate all layout options and draw the tree for each one.

57

;; (dolist (layout '(:up :centered :down))

58

;; (format t "Layout = :~A~%" layout)

59

;; (fmt-tree t tree :layout layout)))

60

61

;; Layout = :UP

62

;; ╭─ C2

63

;; │ ╭─ C1

64

;; ├─ B3

65

;; ├─ B2

66

;; ├─ B1

67

;; A

68

;; Layout = :CENTERED

69

;; ╭─ B2

70

;; ├─ B1

71

;; A

72

;; ├─ B3

73

;; │ ╰─ C1

74

;; ╰─ C2

75

;; Layout = :DOWN

76

;; A

77

;; ├─ B1

78

;; ├─ B2

79

;; ├─ B3

80

;; │ ╰─ C1

81

;; ╰─ C2

82

83

;; Unicode plain ASCII representation

84

(defvar *space* " ")

85

(defvar *upper-knee* " ╭─ ") ; " .- "

86

(defvar *pipe* " │ ") ; " | "

87

(defvar *tee* " ├─ ") ; " +- "

88

(defvar *lower-knee* " ╰─ ") ; " '- "

89

90

(defun format-tree-segments (node &key (layout :centered)

91

(node-formatter #'write-to-string))

92

"Format the tree-segments of NODE."

93

(unless node

94

(return-from format-tree-segments nil)) ; nothing to do here

95

(setq node (ensure-cons node))

96

(flet ((prefix-node-strings (child-node &key layout node-formatter

97

                                                (upper-connector *pipe*)

98

                                                (root-connector  *tee*)

99

                                                (lower-connector *pipe*))

100

"A local utility to add connectors to a string representation

101

of a tree segment to connect it to other tree segments."

102

(multiple-value-bind (u r l)

103

(format-tree-segments child-node

104

:layout layout

105

:node-formatter node-formatter)

106

                                         ; prefix tree segment with connector glyphs to connect it to

107

; other segments.

108

(nconc

109

(mapcar

110

(lambda (str) (concatenate 'string upper-connector str))

111

u)

112

(list (concatenate 'string root-connector r))

113

(mapcar

114

(lambda (str) (concatenate 'string lower-connector str))

115

l)))))

116

(let* ((children (rest node))

117

(pivot (case layout ; the split point of the list of children

118

(:up (length children)) ; split at top

119

(:down 0) ; split at bottom

120

(otherwise (round (/ (length children) 2))))) ; bisect

121

(upper-children (reverse (subseq children 0 pivot))) ; above root

122

(lower-children (subseq children pivot))) ; nodes below root

123

(values ; compile multiple value return of upper-children root lower children

124

(when upper-children

125

(loop with top = (prefix-node-strings (first upper-children)

126

:layout layout

127

                                                :node-formatter node-formatter

128

                                                :upper-connector *space*

129

                                                :root-connector  *upper-knee*) ; top node has special connectors

130

for child-node in (rest upper-children)

131

nconc (prefix-node-strings child-node

132

:layout layout

133

:node-formatter node-formatter)

134

into strlist

135

finally (return (nconc top strlist))))

136

(let ((root-name (funcall node-formatter (car node)))) ; root node

137

(if (= 1 (length root-name))

138

(concatenate 'string " " root-name) ; at least 2 chars needed

139

;else

140

root-name))

141

(when lower-children

142

(loop for (head . tail) on lower-children

143

while tail ; omit the last child

144

nconc (prefix-node-strings head

145

:layout layout

146

:node-formatter node-formatter)

147

into strlist

148

finally (return

149

(nconc

150

strlist

151

                                         ; bottom node has special connectors

152

(prefix-node-strings head

153

:layout layout

154

                                                :node-formatter  node-formatter

155

                                                :root-connector  *lower-knee*

156

                                                :lower-connector *space*)))))))))

157

158

(defun fmt-tree (stream root &key

159

(plist nil)

160

(layout :centered)

161

(node-formatter #'write-to-string))

162

"Format ROOT as a tree of nodes, printing to STREAM."

163

(multiple-value-bind (u r l)

164

(format-tree-segments (if plist (cons (car root) (group (cdr root) 2)) root)

165

:layout layout

166

:node-formatter node-formatter)

167

(format stream "~{~A~%~}" (nconc u (list r) l))))

168

169

(defun human-readable-size (number)

170

(check-type number integer)

171

(loop for size in '(80 70 60 50 40 30 20 10)

172

and unit in '("YB" "ZB" "EB" "PB" "TB" "GB" "MB" "KB")

173

when (> (ash number (- size)) 0)

174

do (return-from human-readable-size

175

(format nil "~,2F ~A"

176

(float (/ number (ash 1 size)))

177

unit))))

178

179

;;; MOP

180

(defvar *print-slot-indent* 0)

181

182

 (defun describe-slot (name value &optional (max-slot-name-length 30) (stream t) (indent *print-slot-indent*))

183

"Describe slot NAME with associated VALUE."

184

   (format stream "~%~A~VA = ~A" (make-string indent :initial-element #\space) max-slot-name-length name (prin1-to-line value)))

185

186

;; FROM: sb-impl describe

187

(defun %describe-object (object stream)

188

(let* ((class (class-of object))

189

(slotds (sb-mop:class-slots class))

190

(max-slot-name-length 30)

191

(plist nil))

192

;; Figure out a good width for the slot-name column.

193

(flet ((adjust-slot-name-length (name)

194

(setf max-slot-name-length

195

(max max-slot-name-length (length (symbol-name name))))))

196

(dolist (slotd slotds)

197

(adjust-slot-name-length (sb-mop:slot-definition-name slotd))

198

(push slotd (getf plist (sb-mop:slot-definition-allocation slotd)))))

199

;; Now that we know the width, we can print.

200

(sb-int:doplist (allocation slots) plist

201

(dolist (slotd (nreverse slots))

202

(describe-slot

203

(sb-mop:slot-definition-name slotd)

204

(sb-pcl::slot-value-for-printing object (sb-mop:slot-definition-name slotd)))))

205

(unless slotds

206

(format stream "~@:_No slots."))))

207

208

(defun print-slots (object &optional (stream t))

209

"Print the slots of OBJECT to STREAM."

210

(let ((*print-right-margin* (or *print-right-margin* 72))

211

(*print-circle* t)

212

(*print-circle-not-shared* t)

213

(*print-pretty* t)

214

(*suppress-print-errors*

215

(if (subtypep 'serious-condition *suppress-print-errors*)

216

*suppress-print-errors*

217

'serious-condition)))

218

(%describe-object object stream)))

219

220

(defun format-slots (stream &rest slots)

221

"Print SLOTS to STREAM."

222

(let ((*print-right-margin* (or *print-right-margin* 72))

223

(*print-circle* t)

224

(*print-circle-not-shared* t)

225

(*print-pretty* t)

226

(*suppress-print-errors*

227

(if (subtypep 'serious-condition *suppress-print-errors*)

228

*suppress-print-errors*

229

'serious-condition)))

230

(sb-int:doplist (k v) (print slots)

231

(describe-slot (string k) v 30 stream))

232

(force-output stream)))

233

234

;;; Drawing

235

236

;; These bits of lovely code are sourced from here:

237

;; https://github.com/whalliburton/academy/blob/87a1a13ffbcd60d8553e42e647c59486c761e8cf/drawing.lisp

238

(defun make-bitmap (width height &optional contents)

239

(if contents

240

(make-array (list height width) :initial-contents contents)

241

(make-array (list height width) :initial-element nil)))

242

243

(defvar *bitmap*)

244

(defvar *bitmap-overwrite* nil)

245

246

(defmacro with-bitmap ((width height) &body body)

247

`(let ((*bitmap* (or *bitmap-overwrite* (make-bitmap ,width ,height))))

248

,@body))

249

250

(defun outside-bounds (x y &optional (bitmap *bitmap*))

251

(destructuring-bind (height width) (array-dimensions bitmap)

252

(or (< x 0) (< y 0) (>= x width) (>= y height))))

253

254

(defun set-pixel (x y &optional (bitmap *bitmap*) (value t))

255

(unless (outside-bounds x y bitmap)

256

(setf (aref bitmap y x) value)))

257

258

(defvar *comic-strip*)

259

(defvar *save-drawing-name* nil)

260

261

(defun draw (&optional (bitmap *bitmap*))

262

(cond

263

((and (boundp '*comic-strip*) (not (eq bitmap (comic-strip-bitmap *comic-strip*))))

264

(draw-on-comic-strip *comic-strip* bitmap))

265

(t (destructuring-bind (height width) (array-dimensions bitmap)

266

(loop for y from 0 to (1- height) by 2

267

do (loop for x from 0 to (1- width)

268

do (princ

269

(let ((top (aref bitmap y x))

270

                                   (bottom (when (< y (1- height)) (aref bitmap (1+ y) x))))

271

(cond

272

((or (stringp top) (stringp bottom))

273

(incf x (length (or top bottom)))

274

(or top bottom))

275

((and top bottom) #\FULL_BLOCK)

276

(top #\UPPER_HALF_BLOCK)

277

(bottom #\LOWER_HALF_BLOCK )

278

(t #\space)))))

279

(fresh-line)))))

280

(values))

281

282

(defun draw-from-list (bit-list width)

283

(let ((rows (group bit-list width)))

284

(draw (make-array (list (length rows) width) :initial-contents rows))))

285

286

(defun copy-onto-bitmap (bitmap pattern x y)

287

(loop for row in pattern

288

for yi from y

289

do (loop for character across row

290

for xi from x

291

do (setf (aref bitmap yi xi) (not (eq character #\space)))))

292

bitmap)

293

294

(defun center-on-bitmap (bitmap pattern)

295

(destructuring-bind (height width) (array-dimensions bitmap)

296

(copy-onto-bitmap bitmap pattern

297

(- (floor width 2) (floor (length (car pattern)) 2))

298

(- (floor height 2) (floor (length pattern) 2)))))

299

300

(defun pattern-to-bitmap (pattern)

301

(let ((bitmap (make-bitmap (length (car pattern)) (length pattern))))

302

(loop for row in pattern

303

for y from 0

304

do (loop for character in (coerce row 'list)

305

for x from 0

306

do (when (not (char= character #\space))

307

(setf (aref bitmap y x) t))))

308

bitmap))

309

310

(defun smile ()

311

"When you're smiling, the whole world smiles with you."

312

(draw (pattern-to-bitmap '(" **** "

313

" * * "

314

"* * * *"

315

"* *"

316

"* * * *"

317

"* ** *"

318

" * * "

319

" **** "))))

320

321

(defun draw-border (&optional (bitmap *bitmap*))

322

(destructuring-bind (height width) (array-dimensions bitmap)

323

(loop for x from 0 to (1- width)

324

do (setf (aref bitmap 0 x) t

325

(aref bitmap (1- height) x) t))

326

(loop for y from 1 to (- height 2)

327

do (setf (aref bitmap y 0) t

328

(aref bitmap y (1- width)) t)))

329

(values))

330

331

;;; Computer Graphics - Principles and Practice by Donald Hearn and M. Pauline Baker

332

(defun draw-circle (x-center y-center radius &optional (bitmap *bitmap*))

333

(labels ((pixel (x y) (set-pixel (+ x-center x) (+ y-center y) bitmap))

334

(draw-points (x y)

335

(pixel x y)

336

(pixel (- x) y)

337

(pixel x (- y))

338

(pixel (- x) (- y))

339

(pixel y x)

340

(pixel (- y) x)

341

(pixel y (- x))

342

(pixel (- y) (- x))))

343

(loop with x = 0

344

with y = radius

345

with p = (- 1 radius)

346

initially (draw-points x y)

347

while (< x y)

348

do (incf x)

349

(if (< p 0)

350

(incf p (+ (* 2 x) 1))

351

(progn

352

(decf y)

353

(incf p (+ (* 2 (- x y)) 1))))

354

(draw-points x y))))

355

356

(defun bullseye (&key (size 64) (step 4) filled (draw t))

357

"Draw a bullseye."

358

(with-bitmap (size size)

359

(let ((mid (floor size 2)))

360

(loop for radius from 2 to mid by step

361

do (draw-circle mid mid radius))

362

(when filled

363

(loop for x from 2 to mid by (* 2 step)

364

do (fill-bitmap (+ mid x 1) mid)))

365

(if draw

366

(draw)

367

*bitmap*))))

368

369

(defun moire (&key (size 64) (step 4) (filled t) (offset 16))

370

"Draw a Moiré pattern."

371

(let ((*bitmap* (make-bitmap (+ size offset) size))

372

(one (bullseye :size size :step step :filled filled :draw nil)))

373

(copy-bitmap-onto-bitmap one *bitmap* 0 0)

374

(copy-bitmap-onto-bitmap one *bitmap* offset 0)

375

(draw *bitmap*)))

376

377

(defun draw-line (xa ya xb yb &optional (bitmap *bitmap*))

378

(let* ((dx (- xb xa))

379

(dy (- yb ya))

380

(steps (if (> (abs dx) (abs dy)) (abs dx) (abs dy)))

381

(xi (/ dx steps))

382

(yi (/ dy steps)))

383

(set-pixel xa ya bitmap)

384

(loop with x = xa

385

with y = ya

386

for k from 0 to (1- steps)

387

do (incf x xi)

388

(incf y yi)

389

(set-pixel (floor x) (floor y) bitmap))))

390

391

(defun sunbeam (&key (step 8) (size 64))

392

"Draw a sunbeam."

393

(with-bitmap (size size)

394

(loop for x from 0 to size by step

395

do (draw-line 0 (1- size) x 0)

396

(draw-line 0 (1- size) (1- size) x))

397

(draw)))

398

399

(defun fill-bitmap (x y &optional (bitmap *bitmap*))

400

(unless (outside-bounds x y bitmap)

401

(unless (aref bitmap y x)

402

(setf (aref bitmap y x) t)

403

(fill-bitmap (+ x 1) y bitmap)

404

(fill-bitmap (- x 1) y bitmap)

405

(fill-bitmap x (+ y 1) bitmap)

406

(fill-bitmap x (- y 1) bitmap))))

407

408

(defun draw-filled-circle (x-center y-center radius &optional (bitmap *bitmap*))

409

(draw-circle x-center y-center radius bitmap)

410

(fill-bitmap x-center y-center bitmap))

411

412

(defun sun (&key (size 64))

413

"Draw a sun."

414

(with-bitmap (size size)

415

(let ((mid (floor size 2)))

416

(draw-filled-circle mid mid (1- mid))

417

(draw))))

418

419

;;; Attention Hackers! Exercises are good for the soul.

420

;;;

421

;;; Someone with the desire could expand PEACE to draw peace symbols of any size.

422

423

(defun peace ()

424

"Peace on Earth."

425

(with-bitmap (12 12)

426

(draw-circle 6 6 5)

427

(draw-line 6 10 6 1)

428

(draw-line 6 6 3 9)

429

(draw-line 6 6 9 9)

430

(draw)))

431

432

(defun copy-bitmap-onto-bitmap (from-bitmap to-bitmap x y &key (fn (lambda (a b) (or a b))))

433

(destructuring-bind (height width) (array-dimensions from-bitmap)

434

(loop for yi from 0 to (1- height)

435

do (loop for xi from 0 to (1- width)

436

do (let ((from (aref from-bitmap yi xi))

437

(to (aref to-bitmap (+ y yi) (+ x xi))))

438

(set-pixel (+ x xi) (+ y yi)

439

to-bitmap

440

(funcall fn from to)))))))

441

442

(defun center-bitmap-onto-bitmap (from-bitmap to-bitmap)

443

(destructuring-bind (fh fw) (array-dimensions from-bitmap)

444

(destructuring-bind (th tw) (array-dimensions to-bitmap)

445

(copy-bitmap-onto-bitmap from-bitmap to-bitmap

446

(floor (- tw fw) 2)

447

(floor (- th fh) 2)))))

448

449

(defstruct comic-strip bitmap width height columns rows column)

450

451

(defmacro with-comic-strip ((&key (width 32) (height 32) (columns 3) (action 'draw)) &body body)

452

`(let ((*comic-strip* (make-comic-strip :bitmap (make-bitmap (* ,width ,columns) 0)

453

                                           :width ,width :height ,height :columns ,columns

454

:rows 0 :column 0)))

455

,@body

456

(,action (comic-strip-bitmap *comic-strip*))))

457

458

(defun draw-on-comic-strip (strip cell-bitmap)

459

(with-slots (rows column width height columns bitmap) strip

460

(when (= column 0)

461

(incf rows)

462

(setf bitmap

463

             (adjust-array bitmap (list (* rows height) (* columns width)) :initial-element nil)))

464

(copy-bitmap-onto-bitmap cell-bitmap bitmap (* column width) (* (1- rows) height))

465

(setf column (mod (1+ column) columns))))

466

467

(defun plot-function (fn start end &optional (width 64) (height 32))

468

"Show a graph of FN of size WIDTHxHEIGHT with the X axis bounded by START and END."

469

(with-bitmap (width height)

470

(let ((step (/ (- end start) width))

471

(mid (floor height 2)))

472

(loop for x from start to end by step

473

for xi from 0

474

do (let ((y (- mid (floor (funcall fn x) step))))

475

(set-pixel xi (floor y))))

476

(draw-border)

477

(draw))))

478

479

(defun rotate-rows-to-columns (rows)

480

(loop for remaining = rows then (mapcar #'cdr remaining)

481

while (not (every #'null remaining))

482

collect (mapcar #'car remaining)))

483

484

(defun maximize-length (list &key (key #'identity))

485

(loop for element in list maximizing (length (funcall key element))))

486

487

(defun pad-list (list length &optional (pad-element nil))

488

(loop for el on list

489

for x from 1

490

do (when (null (cdr el))

491

(setf (cdr el) (make-list (- length x) :initial-element pad-element))

492

(return list))))

493

494

(defun print-table (rows &key (gap " ") (align :left))

495

(when rows

496

(loop

497

with max-row-length = (apply #'max (mapcar #'length rows))

498

with control-string =

499

(format nil

500

(concatenate

501

                                    'string "~{~~~D" (ecase align (:right "@") (:left "")) "A~^" gap "~}~%")

502

                                   (mapcar (lambda (row) (maximize-length row :key #'princ-to-string))

503

(rotate-rows-to-columns rows)))

504

for row in (mapcar (lambda (row) (pad-list row max-row-length "")) rows)

505

do (apply #'format t control-string row))))

506

507

(defun print-heading (text &key (underline "▀"))

508

(terpri)

509

(write-string text)

510

(fresh-line)

511

(dotimes (i (length text)) (write-string underline))

512

(fresh-line)

513

(terpri))

514

515

(defun print-in-box (string)

516

(flet ((print-times (count string) (dotimes (x count) (princ string))))

517

(let* ((lines (sb-unicode:lines string))

518

(columns (apply #'max (mapcar #'length lines))))

519

(princ "┌") (print-times columns "─") (princ "┐") (fresh-line)

520

(loop for line in lines

521

do (princ "│")

522

(princ line)

523

(print-times (- columns (length line)) " ")

524

(princ "│")

525

(fresh-line))

526

(princ "└") (print-times columns "─") (princ "┘")

527

(fresh-line))))

528

529

(defmacro print-boxed (&rest body)

530

`(print-in-box

531

(with-output-to-string (*standard-output*)

532

,@body)))

533

534

;;; Box

535

;; TODO 2025-04-04:

536

;; APL Box Formatting (BQN/Dyalog/J)

537

538

(defun draw-one-in-chance (&optional (chance 3))

539

"Show a 32x32 bitmap with pixels on with a one in CHANCE probability."

540

(draw-from-list (random-booleans (* 32 32) chance) 32))

541

542

(defun draw-chance (&optional (steps 80))

543

"Show a bitmap with each columns pixels with decreasing probability."

544

(draw (make-bitmap steps 32

545

(loop for y from 1 to 32

546

collect (loop for i from 1 to steps

547

                                          collect (>= (random steps) i))))))

548

 ���������������������������������������������������������������������������������������������������