From ace56f02c277c70a4332da1c972a945196502f8b Mon Sep 17 00:00:00 2001
From: Nikolay Puzanov <punzik@gmail.com>
Date: Wed, 11 Dec 2013 19:01:18 +0400
Subject: [PATCH] Archive.

---
 kot-kit.scm |  78 +++++++++++++++++++
 turtle.rkt  | 216 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 294 insertions(+)
 create mode 100644 kot-kit.scm
 create mode 100644 turtle.rkt

diff --git a/kot-kit.scm b/kot-kit.scm
new file mode 100644
index 0000000..7f48575
--- /dev/null
+++ b/kot-kit.scm
@@ -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:
diff --git a/turtle.rkt b/turtle.rkt
new file mode 100644
index 0000000..c42aef1
--- /dev/null
+++ b/turtle.rkt
@@ -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: