【土卫五号向】【怀旧？】ASCII模式游戏的胡乱物？

(clrscr)
(display "hello world")
(exit)

(clrscr)
(let loop ()
(let ((c (inkey)))
  (display (char->integer c))
  (newline)
  (loop)))
(exit)

(define (wait-key)
  (let loop ()
    (define (pad c)
      (case (char->integer c)
        ((72) 'u)
        ((80) 'd)
        ((75) 'l)
        ((77) 'r)
        (else (loop))))
    (let* ((key-char (inkey))
          (key-code (char->integer key-char)))
      (cond
        ((member key-code '(224 0)) (pad (inkey)))
        ((char-ci=? key-char #\z) 'a)
        ((char-ci=? key-char #\x) 'b)
        ((char-ci=? key-char #\c) 's)
        ((char-ci=? key-char #\w) 'u)
        ((char-ci=? key-char #\s) 'd)
        ((char-ci=? key-char #\a) 'l)
        ((char-ci=? key-char #\d) 'r)
        ((= key-code 13) 'a)
        ((= key-code 32) 'a)
        ((= key-code 8) 'b)
        ((char-ci=? key-char #\q) 'b)
        ((= key-code 27) 's)
        ((= key-code 3) (exit))
        (else (loop))))))

(define (wait-key)
  (define (co key-map)
    (define (co lst)
      (cons
        (char-downcase
        (string-ref (symbol->string (car lst)) 0))
      (cadr lst)))
    (map co key-map))
  (define key-map
    (co '((w u)(s d)(a l)(d r)(z a)(x b)(c s))))
  (let loop ()
    (cond
      ((assoc (inkey) key-map)
      =>(lambda (x) (if x (cdr x) (loop)))))))

(define (filter pred list)
  (cond
    ((null? list) '())
    ((pred (car list))
    (cons (car list) (filter pred (cdr list))))
    (else (filter pred (cdr list)))))
;(display (filter even? '(1 2 3 4 5 6)))
(define (curry fun . args)
          (lambda x
            (apply fun (append args x))))
;((curry + 2) 3)
(define (assert ture . msgs)
  (if (not ture) (begin (for-each (lambda (x) (display x)) msgs) (error "assert-fail"))))
(define (require name)
  ;(push! *require-loaded* name)
  (load (string-append (symbol->string name) ".ss")))

(define (ui-choose msg . items)
  (define (show vec cur)
    (define cur (modulo cur (vector-length vec)))
    (clrscr)
    (display msg)
    (newline)
    (do ((i 0 (+ i 1))) ((= i (vector-length vec)) 1)
      (display (if (= i cur) " * " "  "))
      (display (vector-ref vec i))
      (newline))
    (let ((k (wait-key)))
      (case k
        ((u) (show vec (- cur 1)))
        ((d) (show vec (+ cur 1)))
        ((a) (+ cur 1))
        (else (show vec cur)))))
  (show (list->vector items) 0))
;(display (ui-choose "where to go?" "walk" "eat" "sleep"))

(define (show-map-scene5)
  (define (map-event p x y)
    (cond
      ((assoc (list x y) (filter (lambda (x) (eqv? #\$ (cadr x))) map-objs))
      (clrscr)
      (display "hello world")
      (inkey))
      ((assoc (list x y) map-objs)
      =>(lambda (x) '()))
      (else (p 'put x y)))
    (map-loop))
  (define p (make-movable map-event))
  (define budr1 (make-pos-list
                '("......................"
                  ".......#.......#......"
                  "..........#......$...."
                  ".....$................"
                  ".............#........"
                  "......#..............."
                  "...............#......"
                  "........#.....#.......")))
  (define map-objs
    (cons
    (list (p 'position-ref) "@")
    (budr1 'data-ref)));map this
  (define (map-char-of-pos x y);map-show    make this simpler
    (let ((lst (assoc-all (list x y) map-objs)));map-objs
      (if (not lst) "." (cadr (car lst)))))
  (define (map-loop)
    (clrscr)
    (display "[map]\n")
    (map-view-display (budr1 'width) (budr1 'height) map-char-of-pos)
    (input-and-move (curry p 'move)))
  (map-loop))
(show-map-scene5)

(define (dispatch->callable host)
  (define (object message . args)
    (apply (host message) args))
  object)
(define (make-movable call-with-this-new-position)
  (define position (list 0 0))
  (define (position-ref)
    position)
  (define (position-copy)
    (append position))
  (define (position-set! x y)
    (set-car! position x)
    (set-car! (cdr position) y))
  (define (move dx dy)
    (let ((new-x (+ dx (car position)))
          (new-y (+ dy (cadr position))))
      ;;tail-rec/cps
      (call-with-this-new-position this new-x new-y)))
  (define (dispatch message)
    (case message
      ((position-ref) position-ref)
      ((position) position-copy)
      ((position-set!) position-set!)
      ((put) position-set!)
      ((move) move)
      (else (error message))))
  (define this (dispatch->callable dispatch))
  this)
(define (input-and-move move)
  ;;with-system-menu
  (case (wait-key)
    ((u) (move +0 -1))
    ((d) (move +0 +1))
    ((l) (move -1 +0))
    ((r) (move +1 +0))))

(define (assoc-all obj alist)
  (let ((f (filter (lambda (x) (equal? (car x) obj)) alist)))
    (if (null? f) #f f)))
;;;ui-display-map
(define (map-view-display width height call-with-char-position)
  (do ((y 0 (+ y 1))) ((= y height))
    (do ((x 0 (+ x 1))) ((= x width))
      (let ((chr (call-with-char-position x y)))
        (if (or (not chr) (null? chr))
            (display ".")
            (display chr)))
      ;(display (call-with-char-position x y))
      );when get #f or '() display "."?
    (display "\n")))

;;make-pos-list
(define (pos-list-of-strs map-data)
  '(demo-data
    ("##....###"
    "#.$.....#"
    "#.....@.#"
    "#.$..####"))
  (let loop ((x 0) (y 0) (w 0) (h 0)(it map-data) (ret '()))
    (cond
      ((null? it)
      (cons (list w h) ret));return this
      ((= x (string-length (car it)))
      (loop 0 (+ y 1) (max x w) (+ h 1) (cdr it) ret))
      ((equal? (string-ref (car it) x) #\.)
      (loop (+ x 1) y w h it ret))
      (else
      (loop (+ x 1) y w h it
            (cons (list (list x y) (string-ref (car it) x)) ret))))))
(define (make-pos-list string-list-data)
  (define _ (pos-list-of-strs string-list-data))
  (define (dispatch message)
    (case message
      ((width)
      (lambda () (caar _)))
      ((height)
      (lambda () (cadar _)))
      ((data-ref)
      (lambda ()(cdr _)))
      (else (error message))))
  (dispatch->callable dispatch))

(define map2
  '(("##....###"
    "#.......#"
    "#.....@.#"
    "#....####")
    ((#\# floor)
    (#\. floor)
    (#\@ floor player))
    ((floor #\#))
    ))

(define (make-state)
  (define alist-data (list))
  (define (dispatch message)
    (case message
      ((get)
      (lambda (key)
        (cond ((assoc key alist-data)=>(lambda (x) (cdr x)))(else #f))))
      ((put)
      (lambda (key value)
        (let ((ptr (assoc key alist-data)))
          (if ptr (set-cdr! ptr value)
              (set! alist-data (cons (cons key value) alist-data))))))
      ((save)
      (lambda (file)
        (call-with-output-file file
          (lambda (port)
            (write alist-data port)))))
      ((load)
      (lambda (file)
        (call-with-input-file file
          (lambda (port)
            (let ((sexp (read port)))
              (if (eof-object? sexp)
                  (set! alist-data (list))
                  (set! alist-data sexp)))))))
      (else (error message))))
  dispatch)