examples/solitaire.sgl — sigil-studio

1;;; solitaire.sgl - Cyberpunk Solitaire

2;;;

3;;; A keyboard-controlled Klondike solitaire game with cyberpunk aesthetics.

4;;;

5;;; Controls:

6;;; a s d f - Select tableau columns 1-4

7;;; j k l - Select tableau columns 5-7

8;;; w - Flip card from stock to waste

9;;; e - Select card from waste pile

10;;; u i o p - Select foundation piles 1-4

11;;; Escape - Quit

12;;; n - New game

14(import (sigil core)

15 (sigil math)

16 (sigil app)

17 (sigil graphics)

18 (sigil graphics font))

20;; ============================================================

21;; CONSTANTS

22;; ============================================================

24;; Viewport size

25(define SCREEN-WIDTH 800)

26(define SCREEN-HEIGHT 600)

28;; Card dimensions

29(define CARD-WIDTH 60)

30(define CARD-HEIGHT 80)

31(define CARD-GAP 15)

32(define STACK-OFFSET 20) ;; Vertical offset for stacked cards

34;; Colors (cyberpunk theme)

35(define BG-R 0.04)

36(define BG-G 0.04)

37(define BG-B 0.10)

39(define CARD-BACK-R 0.1)

40(define CARD-BACK-G 0.1)

41(define CARD-BACK-B 0.15)

43(define CARD-FACE-R 0.12)

44(define CARD-FACE-G 0.12)

45(define CARD-FACE-B 0.14)

47(define NEON-CYAN-R 0.0)

48(define NEON-CYAN-G 1.0)

49(define NEON-CYAN-B 1.0)

51(define NEON-PINK-R 1.0)

52(define NEON-PINK-G 0.0)

53(define NEON-PINK-B 0.4)

55(define NEON-YELLOW-R 1.0)

56(define NEON-YELLOW-G 1.0)

57(define NEON-YELLOW-B 0.0)

59(define DIM-CYAN-R 0.0)

60(define DIM-CYAN-G 0.4)

61(define DIM-CYAN-B 0.4)

63;; ============================================================

64;; CARD DATA STRUCTURES

65;; ============================================================

67;; Card is a vector: #(suit rank face-up?)

68;; Suits: 0=hearts, 1=diamonds, 2=clubs, 3=spades

69;; Ranks: 1=Ace, 2-10, 11=Jack, 12=Queen, 13=King

71(define (make-card suit rank)

72 (vector suit rank #f))

74(define (card-suit card) (vector-ref card 0))

75(define (card-rank card) (vector-ref card 1))

76(define (card-face-up? card) (vector-ref card 2))

78(define (card-set-face-up! card up?)

79 (vector-set! card 2 up?))

81(define (card-flip! card)

82 (vector-set! card 2 (not (card-face-up? card))))

84;; Red suits: hearts (0), diamonds (1)

85;; Black suits: clubs (2), spades (3)

86(define (card-red? card)

87 (< (card-suit card) 2))

89(define (card-black? card)

90 (>= (card-suit card) 2))

92(define (suit-symbol suit)

93 (case suit

94 ((0) "H")

95 ((1) "D")

96 ((2) "C")

97 ((3) "S")

98 (else "?")))

100(define (rank-symbol rank)

101 (case rank

102 ((1) "A")

103 ((11) "J")

104 ((12) "Q")

105 ((13) "K")

106 (else (number->string rank))))

107

108;; ============================================================

109;; DECK CREATION AND SHUFFLING

110;; ============================================================

111

112(define (make-deck)

113 (let ((deck '()))

114 (let suit-loop ((suit 0))

115 (when (< suit 4)

116 (let rank-loop ((rank 1))

117 (when (< rank 14)

118 (set! deck (cons (make-card suit rank) deck))

119 (rank-loop (+ rank 1))))

120 (suit-loop (+ suit 1))))

121 deck))

122

123;; Fisher-Yates shuffle using a simple LCG random

124(define *random-state* 12345)

125

126(define (random-next)

127 (set! *random-state*

128 (modulo (+ (* *random-state* 1103515245) 12345) 2147483648))

129 *random-state*)

130

131(define (random-int n)

132 (modulo (random-next) n))

133

134(define (shuffle-list lst)

135 (let ((vec (list->vector lst))

136 (n (length lst)))

137 (let loop ((i (- n 1)))

138 (when (>= i 1)

139 (let* ((j (random-int (+ i 1)))

140 (tmp (vector-ref vec i)))

141 (vector-set! vec i (vector-ref vec j))

142 (vector-set! vec j tmp))

143 (loop (- i 1))))

144 (vector->list vec)))

145

146;; ============================================================

147;; GAME STATE

148;; ============================================================

149

150(define *stock* '()) ;; Face-down draw pile

151(define *waste* '()) ;; Face-up drawn cards

152(define *foundations* #f) ;; Vector of 4 foundation piles (lists)

153(define *tableau* #f) ;; Vector of 7 tableau columns (lists)

154

155;; Selection state

156(define *selected-source* #f) ;; 'stock, 'waste, 'foundation, 'tableau, or #f

157(define *selected-index* #f) ;; Which pile (0-3 for foundation, 0-6 for tableau)

158(define *selected-count* 1) ;; How many cards selected from tableau

159

160;; Font

161(define *font* #f)

162(define *font-small* #f)

163

164;; Messages

165(define *message* "")

166(define *message-timer* 0.0)

167

168;; ============================================================

169;; GAME INITIALIZATION

170;; ============================================================

171

172(define (init-game)

173 ;; Seed random with time

174 (set! *random-state* (truncate (* (time-elapsed) 1000000)))

175

176 ;; Create and shuffle deck

177 (let ((deck (shuffle-list (make-deck))))

178 ;; Initialize foundations (empty)

179 (set! *foundations* (vector '() '() '() '()))

180

181 ;; Initialize tableau - deal 1,2,3,4,5,6,7 cards

182 (set! *tableau* (vector '() '() '() '() '() '() '()))

183 (let deal-loop ((col 0) (deck deck))

184 (if (< col 7)

185 (let ((cards (take deck (+ col 1)))

186 (rest (drop deck (+ col 1))))

187 ;; Flip the top card face-up

188 (card-set-face-up! (car (reverse cards)) #t)

189 (vector-set! *tableau* col (reverse cards))

190 (deal-loop (+ col 1) rest))

191 ;; Remaining cards go to stock

192 (set! *stock* deck)))

193

194 ;; Clear waste and selection

195 (set! *waste* '())

196 (clear-selection)

197 (show-message "New game started")))

198

199;; Helper: take first n elements

200(define (take lst n)

201 (if (or (<= n 0) (null? lst))

202 '()

203 (cons (car lst) (take (cdr lst) (- n 1)))))

204

205;; Helper: drop first n elements

206(define (drop lst n)

207 (if (or (<= n 0) (null? lst))

208 lst

209 (drop (cdr lst) (- n 1))))

210

211;; ============================================================

212;; SELECTION

213;; ============================================================

214

215(define (clear-selection)

216 (set! *selected-source* #f)

217 (set! *selected-index* #f)

218 (set! *selected-count* 1))

219

220(define (select-tableau col)

221 (let ((pile (vector-ref *tableau* col)))

222 (if (null? pile)

223 ;; Empty pile - if we have a selection, try to move there

224 (if *selected-source*

225 (try-move-to-tableau col)

226 (show-message "Empty column"))

227 ;; Non-empty pile

228 (if (and (eq? *selected-source* 'tableau)

229 (= *selected-index* col))

230 ;; Already selected this column - increase selection count

231 (let ((face-up-count (count-face-up pile)))

232 (if (< *selected-count* face-up-count)

233 (set! *selected-count* (+ *selected-count* 1))

234 (show-message "Can't select more cards")))

235 ;; New selection or moving here

236 (if *selected-source*

237 ;; Try to move to this tableau

238 (try-move-to-tableau col)

239 ;; New selection

240 (begin

241 (set! *selected-source* 'tableau)

242 (set! *selected-index* col)

243 (set! *selected-count* 1)))))))

244

245(define (select-foundation idx)

246 (let ((pile (vector-ref *foundations* idx)))

247 (if *selected-source*

248 ;; Try to move to foundation

249 (try-move-to-foundation idx)

250 ;; Select from foundation (rarely useful, but allowed)

251 (if (null? pile)

252 (show-message "Empty foundation")

253 (begin

254 (set! *selected-source* 'foundation)

255 (set! *selected-index* idx)

256 (set! *selected-count* 1))))))

257

258(define (select-waste)

259 (if (null? *waste*)

260 (show-message "No cards in waste")

261 (if *selected-source*

262 ;; Clear selection and select waste

263 (begin

264 (clear-selection)

265 (set! *selected-source* 'waste)

266 (set! *selected-index* 0)

267 (set! *selected-count* 1))

268 ;; New selection from waste

269 (begin

270 (set! *selected-source* 'waste)

271 (set! *selected-index* 0)

272 (set! *selected-count* 1)))))

273

274(define (flip-stock)

275 (clear-selection)

276 (if (null? *stock*)

277 ;; Recycle waste back to stock

278 (if (null? *waste*)

279 (show-message "No cards to flip")

280 (begin

281 (set! *stock* (map (lambda (c)

282 (card-set-face-up! c #f) c)

283 (reverse *waste*)))

284 (set! *waste* '())

285 (show-message "Stock recycled")))

286 ;; Flip one card from stock to waste

287 (let ((card (car *stock*)))

288 (set! *stock* (cdr *stock*))

289 (card-set-face-up! card #t)

290 (set! *waste* (cons card *waste*)))))

291

292;; ============================================================

293;; MOVE VALIDATION AND EXECUTION

294;; ============================================================

295

296(define (count-face-up pile)

297 (let loop ((pile pile) (count 0))

298 (if (or (null? pile) (not (card-face-up? (car pile))))

299 count

300 (loop (cdr pile) (+ count 1)))))

301

302(define (get-selected-cards)

303 (case *selected-source*

304 ((waste) (list (car *waste*)))

305 ((foundation) (list (car (vector-ref *foundations* *selected-index*))))

306 ((tableau)

307 (take (vector-ref *tableau* *selected-index*) *selected-count*))

308 (else '())))

309

310(define (can-place-on-tableau? cards target-pile)

311 (if (null? cards)

312 #f

313 (let ((bottom-card (car (reverse cards))))

314 (if (null? target-pile)

315 ;; Empty pile - only King can go there

316 (= (card-rank bottom-card) 13)

317 ;; Must alternate color and be one less in rank

318 (let ((top-card (car target-pile)))

319 (and (card-face-up? top-card)

320 (not (eq? (card-red? bottom-card) (card-red? top-card)))

321 (= (card-rank bottom-card) (- (card-rank top-card) 1))))))))

322

323(define (can-place-on-foundation? card foundation-pile)

324 (if (null? foundation-pile)

325 ;; Empty foundation - only Ace

326 (= (card-rank card) 1)

327 ;; Must be same suit and one higher

328 (let ((top-card (car foundation-pile)))

329 (and (= (card-suit card) (card-suit top-card))

330 (= (card-rank card) (+ (card-rank top-card) 1))))))

331

332(define (try-move-to-tableau target-col)

333 (let ((cards (get-selected-cards))

334 (target-pile (vector-ref *tableau* target-col)))

335 (if (can-place-on-tableau? cards target-pile)

336 (begin

337 ;; Remove cards from source

338 (remove-selected-cards)

339 ;; Add to target

340 (vector-set! *tableau* target-col (append cards target-pile))

341 (clear-selection)

342 (show-message "Moved!"))

343 (begin

344 (clear-selection)

345 (show-message "Invalid move")))))

346

347(define (try-move-to-foundation target-idx)

348 (let ((cards (get-selected-cards)))

349 ;; Can only move single card to foundation

350 (if (not (= (length cards) 1))

351 (begin

352 (show-message "Only single cards to foundation")

353 (clear-selection))

354 (let ((card (car cards))

355 (foundation-pile (vector-ref *foundations* target-idx)))

356 (if (can-place-on-foundation? card foundation-pile)

357 (begin

358 (remove-selected-cards)

359 (vector-set! *foundations* target-idx (cons card foundation-pile))

360 (clear-selection)

361 (check-win)

362 (show-message "To foundation!"))

363 (begin

364 (clear-selection)

365 (show-message "Invalid foundation move")))))))

366

367(define (remove-selected-cards)

368 (case *selected-source*

369 ((waste)

370 (set! *waste* (cdr *waste*)))

371 ((foundation)

372 (let ((pile (vector-ref *foundations* *selected-index*)))

373 (vector-set! *foundations* *selected-index* (cdr pile))))

374 ((tableau)

375 (let ((pile (vector-ref *tableau* *selected-index*)))

376 (vector-set! *tableau* *selected-index* (drop pile *selected-count*))

377 ;; Flip newly exposed card

378 (let ((new-pile (vector-ref *tableau* *selected-index*)))

379 (when (and (not (null? new-pile))

380 (not (card-face-up? (car new-pile))))

381 (card-set-face-up! (car new-pile) #t)))))))

382

383(define (check-win)

384 (let ((total (+ (length (vector-ref *foundations* 0))

385 (length (vector-ref *foundations* 1))

386 (length (vector-ref *foundations* 2))

387 (length (vector-ref *foundations* 3)))))

388 (when (= total 52)

389 (show-message "YOU WIN!"))))

390

391;; ============================================================

392;; MESSAGES

393;; ============================================================

394

395(define (show-message msg)

396 (set! *message* msg)

397 (set! *message-timer* 2.0))

398

399(define (update-message dt)

400 (when (> *message-timer* 0)

401 (set! *message-timer* (- *message-timer* dt))))

402

403;; ============================================================

404;; RENDERING

405;; ============================================================

406

407(define (draw-card-back x y selected?)

408 ;; Card background

409 (set-color CARD-BACK-R CARD-BACK-G CARD-BACK-B)

410 (draw-filled-rect x y CARD-WIDTH CARD-HEIGHT)

411 ;; Border

412 (if selected?

413 (set-color NEON-YELLOW-R NEON-YELLOW-G NEON-YELLOW-B)

414 (set-color DIM-CYAN-R DIM-CYAN-G DIM-CYAN-B))

415 (draw-rect x y CARD-WIDTH CARD-HEIGHT))

416

417(define (draw-card-face card x y selected?)

418 ;; Card background

419 (set-color CARD-FACE-R CARD-FACE-G CARD-FACE-B)

420 (draw-filled-rect x y CARD-WIDTH CARD-HEIGHT)

421

422 ;; Border color based on suit

423 (if selected?

424 (set-color NEON-YELLOW-R NEON-YELLOW-G NEON-YELLOW-B)

425 (if (card-red? card)

426 (set-color NEON-PINK-R NEON-PINK-G NEON-PINK-B)

427 (set-color NEON-CYAN-R NEON-CYAN-G NEON-CYAN-B)))

428 (draw-rect x y CARD-WIDTH CARD-HEIGHT)

429

430 ;; Draw rank and suit

431 (when *font*

432 (let ((rank-str (rank-symbol (card-rank card)))

433 (suit-str (suit-symbol (card-suit card))))

434 ;; Suit color for text

435 (if (card-red? card)

436 (set-color NEON-PINK-R NEON-PINK-G NEON-PINK-B)

437 (set-color NEON-CYAN-R NEON-CYAN-G NEON-CYAN-B))

438 (draw-text *font* rank-str (+ x 5) (+ y 25))

439 (draw-text *font* suit-str (+ x 5) (+ y 55)))))

440

441(define (draw-empty-slot x y label)

442 (set-color DIM-CYAN-R DIM-CYAN-G DIM-CYAN-B 0.3)

443 (draw-rect x y CARD-WIDTH CARD-HEIGHT)

444 (when *font-small*

445 (set-color DIM-CYAN-R DIM-CYAN-G DIM-CYAN-B)

446 (draw-text *font-small* label (+ x 20) (+ y 45))))

447

448(define (draw-key-hint x y key)

449 (when *font-small*

450 (set-color DIM-CYAN-R DIM-CYAN-G DIM-CYAN-B)

451 (draw-text *font-small* key x y)))

452

453(define (draw-stock)

454 (let ((x 30) (y 30))

455 ;; Draw stock pile

456 (if (null? *stock*)

457 (draw-empty-slot x y "W")

458 (draw-card-back x y #f))

459 (draw-key-hint (+ x 25) (+ y CARD-HEIGHT 20) "W")))

460

461(define (draw-waste)

462 (let ((x 30) (y (+ 30 CARD-HEIGHT CARD-GAP 30)))

463 (if (null? *waste*)

464 (draw-empty-slot x y "E")

465 (draw-card-face (car *waste*) x y

466 (eq? *selected-source* 'waste)))

467 (draw-key-hint (+ x 25) (+ y CARD-HEIGHT 20) "E")))

468

469(define (draw-foundations)

470 (let ((start-x 250)

471 (y 30)

472 (keys '("U" "I" "O" "P")))

473 (let loop ((i 0))

474 (when (< i 4)

475 (let ((x (+ start-x (* i (+ CARD-WIDTH CARD-GAP))))

476 (pile (vector-ref *foundations* i))

477 (key (list-ref keys i)))

478 (if (null? pile)

479 (draw-empty-slot x y key)

480 (draw-card-face (car pile) x y

481 (and (eq? *selected-source* 'foundation)

482 (= *selected-index* i))))

483 (draw-key-hint (+ x 25) (+ y CARD-HEIGHT 20) key))

484 (loop (+ i 1))))))

485

486(define (draw-tableau)

487 (let ((start-x 50)

488 (start-y 200)

489 (keys '("A" "S" "D" "F" #f "J" "K" "L")))

490 (let col-loop ((col 0))

491 (when (< col 7)

492 (let* ((x (+ start-x (* col (+ CARD-WIDTH CARD-GAP))))

493 (pile (vector-ref *tableau* col))

494 (key (list-ref keys (if (< col 4) col (+ col 1))))

495 (is-selected (and (eq? *selected-source* 'tableau)

496 (= *selected-index* col))))

497 ;; Draw empty slot or cards

498 (if (null? pile)

499 (draw-empty-slot x start-y (or key ""))

500 ;; Draw stack of cards

501 (let ((pile-rev (reverse pile))

502 (count (length pile)))

503 (let card-loop ((i 0) (cards pile-rev))

504 (when (not (null? cards))

505 (let* ((card (car cards))

506 (card-y (+ start-y (* i STACK-OFFSET)))

507 (card-idx (- count i 1))

508 (selected? (and is-selected

509 (< card-idx *selected-count*))))

510 (if (card-face-up? card)

511 (draw-card-face card x card-y selected?)

512 (draw-card-back x card-y #f)))

513 (card-loop (+ i 1) (cdr cards))))))

514 ;; Key hint

515 (when key

516 (draw-key-hint (+ x 25) (+ start-y (* 8 STACK-OFFSET) 30) key)))

517 (col-loop (+ col 1))))))

518

519(define (draw-message)

520 (when (and *font* (> *message-timer* 0))

521 (let ((alpha (min 1.0 *message-timer*)))

522 (set-color 1.0 1.0 1.0 alpha)

523 (draw-text *font* *message* 300 560))))

524

525(define (draw-game)

526 (draw-stock)

527 (draw-waste)

528 (draw-foundations)

529 (draw-tableau)

530 (draw-message))

531

532;; ============================================================

533;; INPUT HANDLING

534;; ============================================================

535

536(define (handle-input)

537 ;; Quit

538 (when (key-pressed? 'escape)

539 (request-quit))

540

541 ;; New game

542 (when (key-pressed? 'n)

543 (init-game))

544

545 ;; Stock

546 (when (key-pressed? 'w)

547 (flip-stock))

548

549 ;; Waste

550 (when (key-pressed? 'e)

551 (select-waste))

552

553 ;; Foundations

554 (when (key-pressed? 'u) (select-foundation 0))

555 (when (key-pressed? 'i) (select-foundation 1))

556 (when (key-pressed? 'o) (select-foundation 2))

557 (when (key-pressed? 'p) (select-foundation 3))

558

559 ;; Tableau

560 (when (key-pressed? 'a) (select-tableau 0))

561 (when (key-pressed? 's) (select-tableau 1))

562 (when (key-pressed? 'd) (select-tableau 2))

563 (when (key-pressed? 'f) (select-tableau 3))

564 (when (key-pressed? 'j) (select-tableau 4))

565 (when (key-pressed? 'k) (select-tableau 5))

566 (when (key-pressed? 'l) (select-tableau 6)))

567

568;; ============================================================

569;; MAIN

570;; ============================================================

571

572(define (on-init)

573 (gfx-setup)

574 (set-viewport SCREEN-WIDTH SCREEN-HEIGHT)

575 (set-letterbox-color 0.02 0.02 0.05)

576

577 ;; Load font (use test font for now)

578 (set! *font* (load-font "packages/sigil-studio/test/Saucer.ttf" 24))

579 (set! *font-small* (load-font "packages/sigil-studio/test/Saucer.ttf" 16))

580

581 (init-game))

582

583(define (on-frame)

584 (let ((dt (frame-time)))

585 (update-message dt)

586 (handle-input)

587

588 (begin-frame)

589 (clear-screen BG-R BG-G BG-B)

590 (draw-game)

591 (end-frame)))

592

593(define (on-cleanup)

594 (display "Thanks for playing!\n"))

595

596(app-run on-init on-frame on-cleanup "Cyberpunk Solitaire" 800 600)