Archive.
This commit is contained in:
Nikolay Puzanov
commit
ace56f02c2
78
kot-kit.scm
Normal file
78
kot-kit.scm
Normal file
@ -0,0 +1,78 @@
|
||||
(import (rnrs io ports (6))) ;; Guile
|
||||
;(require rnrs/io/ports-6) ;; Racket
|
||||
|
||||
(setlocale LC_ALL "")
|
||||
|
||||
(define out-port (current-output-port))
|
||||
(define in-port (current-input-port))
|
||||
|
||||
(define (println . params)
|
||||
(for-each (lambda (x) (display x out-port)) params)
|
||||
(newline out-port) #f)
|
||||
|
||||
;; Helper functions
|
||||
(define (yes? . params)
|
||||
(for-each (lambda (x) (display x out-port)) params)
|
||||
(display "? " out-port)
|
||||
(flush-output-port out-port)
|
||||
(let ((ans (get-line in-port)))
|
||||
(if (= (string-length ans) 0)
|
||||
#f
|
||||
(or
|
||||
(equal? (string-ref ans 0) #\y)
|
||||
(equal? (string-ref ans 0) #\д)))))
|
||||
|
||||
(define (answer . params)
|
||||
(for-each (lambda (x) (display x out-port)) params)
|
||||
(flush-output-port out-port)
|
||||
(get-line in-port))
|
||||
|
||||
;; Copy tree
|
||||
(define (copy-pet-tree pet-tree)
|
||||
(if (null? pet-tree)
|
||||
'()
|
||||
(list (car pet-tree)
|
||||
(cadr pet-tree)
|
||||
(copy-pet-tree (caddr pet-tree))
|
||||
(copy-pet-tree (cadddr pet-tree)))))
|
||||
|
||||
;; Main function
|
||||
(define (game-round pet-tree top-pet-name)
|
||||
(let walk-pet-tree ((pet-tree pet-tree)
|
||||
(y-pet (list top-pet-name)))
|
||||
(if (null? pet-tree)
|
||||
(if (yes? "Это " (car y-pet))
|
||||
(begin
|
||||
(println "Ура, я угадал!")
|
||||
'())
|
||||
(let* ((name (answer "Сдаюсь! Кто это? "))
|
||||
(feature (answer "Чем " name " отличается от " (car y-pet) "? ")))
|
||||
(list name feature '() '()))) ;; return new pet
|
||||
(append
|
||||
(list (car pet-tree)
|
||||
(cadr pet-tree))
|
||||
(if (yes? (cadr pet-tree))
|
||||
(list (walk-pet-tree (caddr pet-tree) pet-tree)
|
||||
(copy-pet-tree (cadddr pet-tree)))
|
||||
(list (copy-pet-tree (caddr pet-tree))
|
||||
(walk-pet-tree (cadddr pet-tree) y-pet)))))))
|
||||
|
||||
(define TREE-FILE-NAME "data.sexp")
|
||||
|
||||
;; Main LOOP
|
||||
(let loop ((pet-tree
|
||||
(if (file-exists? TREE-FILE-NAME)
|
||||
(call-with-input-file TREE-FILE-NAME read)
|
||||
'())))
|
||||
(let ((tree (game-round pet-tree "Кот")))
|
||||
(newline out-port)
|
||||
(if (yes? "Играем еще")
|
||||
(loop tree)
|
||||
(begin
|
||||
;; Racket
|
||||
; (if (file-exists? TREE-FILE-NAME) (delete-file TREE-FILE-NAME) #f)
|
||||
|
||||
(call-with-output-file TREE-FILE-NAME (lambda (p) (write tree p)))
|
||||
))))
|
||||
|
||||
; vim: set ts=2 sts=2 sw=2 expandtab:
|
||||
216
turtle.rkt
Normal file
216
turtle.rkt
Normal file
@ -0,0 +1,216 @@
|
||||
#lang racket/gui
|
||||
(require racket/gui/base)
|
||||
|
||||
(define grid-step 20)
|
||||
(define board-width 30)
|
||||
(define board-height 30)
|
||||
(define zero-x (round (/ board-width 2)))
|
||||
(define zero-y (round (/ board-height 2)))
|
||||
(define default-file-name "turtle.prog")
|
||||
|
||||
(struct point (draw x y))
|
||||
|
||||
(define poly (list (point #t 0 0)))
|
||||
(define draw #t)
|
||||
|
||||
(define frame (new frame%
|
||||
[label "Turtle"]
|
||||
[width (* board-width grid-step)]
|
||||
[height (* board-height grid-step)]))
|
||||
|
||||
(define canvas (new canvas% [parent frame]
|
||||
[paint-callback
|
||||
(λ (canvas dc)
|
||||
(send dc set-smoothing 'unsmoothed)
|
||||
(send dc set-pen "gray" 1 'solid)
|
||||
(let-values (((w h) (send canvas get-size)))
|
||||
(begin
|
||||
(do ((x 0 (+ x grid-step))) ((>= x w) #t)
|
||||
(send dc draw-line x 0 x h))
|
||||
(do ((y 0 (+ y grid-step))) ((>= y h) #t)
|
||||
(send dc draw-line 0 y w y))))
|
||||
(send dc set-smoothing 'smoothed)
|
||||
(send dc set-pen "blue" 2 'solid)
|
||||
(send dc set-brush "blue" 'transparent)
|
||||
(send dc draw-ellipse
|
||||
(- (* grid-step zero-x) 4)
|
||||
(- (* grid-step zero-y) 4)
|
||||
8 8)
|
||||
(let ((points (map (λ (pt)
|
||||
(point (point-draw pt)
|
||||
(* grid-step (+ zero-x (point-x pt)))
|
||||
(* grid-step (+ zero-y (point-y pt)))))
|
||||
poly)))
|
||||
(let loop ((pt0 (car points))
|
||||
(points (cdr points)))
|
||||
(if (null? points)
|
||||
#f
|
||||
(let ((pt (car points)))
|
||||
(begin
|
||||
(if (point-draw pt0)
|
||||
(send dc draw-line
|
||||
(point-x pt0)
|
||||
(point-y pt0)
|
||||
(point-x pt)
|
||||
(point-y pt))
|
||||
#f)
|
||||
(loop pt (cdr points)))))))
|
||||
|
||||
(send dc set-brush "blue" (if draw 'solid 'transparent))
|
||||
(let* ((last-pt (car poly))
|
||||
(last-pt-x (* grid-step (+ zero-x (point-x last-pt))))
|
||||
(last-pt-y (* grid-step (+ zero-y (point-y last-pt)))))
|
||||
(send dc draw-rectangle (- last-pt-x 4) (- last-pt-y 4) 8 8)))]))
|
||||
|
||||
(define (parse-commands str)
|
||||
(if (= (string-length str) 0)
|
||||
(cons 0 0)
|
||||
(let parse ((cmds (string-split str))
|
||||
(x 0)
|
||||
(y 0))
|
||||
(if (null? cmds)
|
||||
(cons x y)
|
||||
(let* ((cmd (string-upcase (car cmds)))
|
||||
(cmd-char (string-ref cmd 0))
|
||||
(cmds-tail (cdr cmds))
|
||||
(argument (λ (dx dy)
|
||||
(if (null? cmds-tail)
|
||||
(begin
|
||||
(printf "Need argument for '~a'\n" cmd)
|
||||
(parse cmds-tail x y))
|
||||
(let ((val (string->number (car cmds-tail))))
|
||||
(if (equal? val #f)
|
||||
(begin
|
||||
(printf "'~a' is not valid argument for '~a'\n" (car cmds-tail) cmd)
|
||||
(parse cmds-tail x y))
|
||||
(parse (cdr cmds-tail)
|
||||
(+ x (* val dx))
|
||||
(+ y (* val dy)))))))))
|
||||
(cond
|
||||
((or (equal? cmd "EXIT")
|
||||
(equal? cmd-char #\Q)) 'quit)
|
||||
((equal? cmd-char #\L) (argument -1 0))
|
||||
((equal? cmd-char #\R) (argument 1 0))
|
||||
((equal? cmd-char #\U) (argument 0 -1))
|
||||
((equal? cmd-char #\D) (argument 0 1))
|
||||
((equal? cmd-char #\C) 'clear)
|
||||
((equal? cmd-char #\P) 'pen)
|
||||
((equal? cmd-char #\S) 'save)
|
||||
((equal? cmd-char #\B) 'back)
|
||||
(else
|
||||
(begin
|
||||
(printf "Unknown command '~a'\n" cmd)
|
||||
(cons 0 0)))))))))
|
||||
|
||||
(define (string-head-equal? s1 s2)
|
||||
(let ((len (min (string-length s1) (string-length s2))))
|
||||
(equal?
|
||||
(substring s1 0 len)
|
||||
(substring s2 0 len))))
|
||||
|
||||
(define (parse-cmd-string str)
|
||||
(if (= (string-length str))
|
||||
'no-more
|
||||
(let parse ((commands (string-split str)) (x 0) (y 0))
|
||||
(if (null? commands)
|
||||
'no-more
|
||||
(let* ((command (string-upcase (car command))))
|
||||
(cond
|
||||
((string-head-equal? command "LEFT"))
|
||||
((string-head-equal? command "RIGHT"))
|
||||
((string-head-equal? command "UP"))
|
||||
((string-head-equal? command "DOWN"))
|
||||
((string-head-equal? command "EXIT"))
|
||||
((string-head-equal? command "QUIT"))
|
||||
((string-head-equal? command "BACK"))
|
||||
((string-head-equal? command "CLEAR"))
|
||||
((string-head-equal? command "PEN"))
|
||||
(else
|
||||
(begin
|
||||
(printf "Unknown command '~a'\n" command)
|
||||
(parse (cdr commands) x y)))
|
||||
))))))
|
||||
|
||||
(define (process poly port interactive)
|
||||
(let ((cmd-line (begin
|
||||
(if interactive
|
||||
(display ">> ")
|
||||
#f)
|
||||
(read-line port))))
|
||||
(if (eof-object? cmd-line)
|
||||
#f
|
||||
(let ((ret (parse-commands cmd-line)))
|
||||
(cond
|
||||
((equal? ret 'quit) #f)
|
||||
((equal? ret 'clear) (list (point #t 0 0)))
|
||||
((equal? ret 'back)
|
||||
(if (> (length poly) 1)
|
||||
(cdr poly)
|
||||
poly))
|
||||
((equal? ret 'pen)
|
||||
(begin
|
||||
(set! draw (not draw))
|
||||
poly))
|
||||
((equal? ret 'save)
|
||||
(begin
|
||||
(call-with-output-file (if (equal? file-name #f)
|
||||
default-file-name
|
||||
file-name)
|
||||
(λ (port)
|
||||
(foldr (lambda (pt pz)
|
||||
(let ((dx (- (point-x pt) (point-x pz)))
|
||||
(dy (- (point-y pt) (point-y pz))))
|
||||
(begin
|
||||
(if (not (eq? (point-draw pt) (point-draw pz)))
|
||||
(fprintf port "pen\n")
|
||||
#f)
|
||||
(if (not (= dx 0))
|
||||
(if (> dx 0)
|
||||
(fprintf port "right ~a " dx)
|
||||
(fprintf port "left ~a " (- dx)))
|
||||
#f)
|
||||
(if (not (= dy 0))
|
||||
(if (> dy 0)
|
||||
(fprintf port "down ~a " dy)
|
||||
(fprintf port "up ~a " (- dy)))
|
||||
#f)
|
||||
(newline port))
|
||||
pt))
|
||||
(point #t 0 0) poly))
|
||||
#:exists 'truncate)
|
||||
poly))
|
||||
(else
|
||||
(let ((dx (car ret))
|
||||
(dy (cdr ret))
|
||||
(prev-x (point-x (car poly)))
|
||||
(prev-y (point-y (car poly))))
|
||||
(if (and (= dx 0) (= dy 0))
|
||||
poly
|
||||
(cons (point draw (+ prev-x dx) (+ prev-y dy)) poly)))))))))
|
||||
|
||||
(define file-name
|
||||
(if (= (vector-length (current-command-line-arguments)) 0)
|
||||
#f
|
||||
(vector-ref (current-command-line-arguments) 0)))
|
||||
|
||||
(send frame show #t)
|
||||
|
||||
(thread (λ ()
|
||||
(let ((func (λ (port interactive)
|
||||
(begin
|
||||
(let loop ()
|
||||
(let ((ret (process poly port interactive)))
|
||||
(if (equal? ret #f)
|
||||
#f
|
||||
(begin
|
||||
(set! poly ret)
|
||||
(send canvas refresh)
|
||||
(loop)))))))))
|
||||
(if (not (equal? file-name #f))
|
||||
(if (file-exists? file-name)
|
||||
(call-with-input-file file-name
|
||||
(λ (port) (func port #f))) #f) #f)
|
||||
(func (current-input-port) #t))
|
||||
(send frame show #f)))
|
||||
|
||||
; vim: set ts=2 sts=2 sw=2 expandtab:
|
||||
Loading…
x
Reference in New Issue
Block a user