├── AUTHORS ├── demo ├── m-gz.png ├── m-xx.png ├── yazi.png ├── brick.png ├── mario-small.png ├── mario-small2.png ├── xml-map.rkt ├── 2.tmx ├── collisiondetect.rkt ├── pallet-game.rkt └── editor1.txt ├── doc ├── images │ ├── changefuture.png │ └── changehistory.png └── doc.md ├── src └── framework │ ├── time-interval.rkt │ ├── statevect.rkt │ └── framework.rkt ├── LICENSE.MIT └── README.md /AUTHORS: -------------------------------------------------------------------------------- 1 | * JiFeng Deng 2 | * WeiTu Zhang -------------------------------------------------------------------------------- /demo/m-gz.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/m-gz.png -------------------------------------------------------------------------------- /demo/m-xx.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/m-xx.png -------------------------------------------------------------------------------- /demo/yazi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/yazi.png -------------------------------------------------------------------------------- /demo/brick.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/brick.png -------------------------------------------------------------------------------- /demo/mario-small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/mario-small.png -------------------------------------------------------------------------------- /demo/mario-small2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/demo/mario-small2.png -------------------------------------------------------------------------------- /doc/images/changefuture.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/doc/images/changefuture.png -------------------------------------------------------------------------------- /doc/images/changehistory.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NetEase/lively-logic/HEAD/doc/images/changehistory.png -------------------------------------------------------------------------------- /src/framework/time-interval.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (define make-interval 3 | (lambda () 4 | (let ([mycurrent-time 0]) 5 | (lambda () 6 | (let ([now-time 0] 7 | [interval 0]) 8 | (begin 9 | (cond [(= mycurrent-time 0) 10 | (set! mycurrent-time (current-milliseconds))]) 11 | (set! now-time (current-milliseconds)) 12 | (set! interval (- now-time mycurrent-time)) 13 | (set! mycurrent-time now-time) 14 | interval)))))) 15 | 16 | (provide make-interval) -------------------------------------------------------------------------------- /demo/xml-map.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require xml) 3 | (require xml/path) 4 | (provide read-map-xml) 5 | (define (read-map-xml filename) 6 | (map power-foo (file->datalist filename))) 7 | 8 | (define file->datalist 9 | (lambda (filename) 10 | (se-path*/list '(data) (xml->xexpr (document-element (read-xml (open-input-file filename))))))) 11 | 12 | (define power-foo 13 | (lambda (x) 14 | (list->vector 15 | (map (lambda (data) 16 | (- (char->integer data) (char->integer #\0))) 17 | (filter (lambda (data) 18 | (and (char<=? data #\9) (char>=? data #\0))) 19 | (string->list x)))))) 20 | 21 | 22 | -------------------------------------------------------------------------------- /demo/2.tmx: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 0,0,0,0,0,0,0,0,0,0,0,0, 9 | 0,0,0,0,0,0,0,0,0,0,0,0, 10 | 0,0,0,0,0,0,0,0,0,0,0,0, 11 | 0,0,0,0,0,0,0,0,0,0,0,0, 12 | 0,0,0,0,0,0,0,0,0,0,0,0, 13 | 0,0,0,0,0,0,0,0,0,0,0,0, 14 | 0,0,0,0,0,0,0,0,1,1,1,1, 15 | 0,0,0,0,0,0,0,0,0,0,0,0, 16 | 0,0,0,0,0,0,0,0,1,0,0,0, 17 | 0,0,0,0,0,0,0,0,1,0,0,0, 18 | 0,0,0,0,0,0,0,0,1,1,1,1, 19 | 1,1,1,1,1,0,0,0,1,1,1,1, 20 | 1,1,1,1,1,0,0,0,1,1,1,1, 21 | 1,1,1,1,1,0,0,0,1,1,1,1 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /LICENSE.MIT: -------------------------------------------------------------------------------- 1 | MIT LICENSE 2 | 3 | Copyright (c) 2012 NetEase, Inc. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | LivelyLogic - This is a game logic real-time adjustment framework. 2 | ============ 3 | 4 | This is a game logic real-time adjustment framework, using the racket language. 5 | 6 | * Homepage: 7 | * Wiki: 8 | * Issues: 9 | * Tags: racket, lisp, game, framework 10 | 11 | Getting Started 12 | --------------- 13 | 14 | clone this repo 15 | 16 | git clone git://github.com/NetEase/lively-logic.git 17 | 18 | This project use racket languages, so need to install the racket. Racket's official website is: . 19 | After the installation is complete, open src/pallet-game.rkt, and then click run. 20 | 21 | Document 22 | -------- 23 | 24 | [document](https://github.com/NetEase/lively-logic/blob/master/doc/doc.md) 25 | 26 | How Can I Contribute 27 | -------------------- 28 | 29 | Fork this project on [GitHub](https://github.com/NetEase/lively-logic), add your improvement, push it to a branch in your fork named for the topic, send a pull request. 30 | 31 | You can also file bugs or feature requests under the [issues](https://github.com/NetEase/lively-logic/issues/) page on GitHub. -------------------------------------------------------------------------------- /src/framework/statevect.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide vectmanager%) 3 | (define vectmanager% 4 | (class object% 5 | (init length val) ; initialization argument 6 | 7 | 8 | ; field 9 | (define vectlen length) 10 | (define vect (make-vector length val)) 11 | (define head 0) 12 | (define tail (- vectlen 1)) 13 | 14 | 15 | ; superclass initialization 16 | (super-new) 17 | 18 | (define/public (insert x) 19 | (begin 20 | (set! tail (remainder (+ tail 1) vectlen)) 21 | (vector-set! vect tail x) 22 | (cond [(= tail head) 23 | (set! head (remainder (+ head 1) vectlen))]))) 24 | (define/public (insertwitholddata) 25 | (begin 26 | (set! tail (remainder (+ tail 1) vectlen)) 27 | (cond [(= tail head) 28 | (set! head (remainder (+ head 1) vectlen))]))) 29 | (define/public (getdata ref) 30 | (cond 31 | [(>= ref vectlen) 32 | #f] 33 | [else 34 | (vector-ref vect (remainder (+ head ref) vectlen))])) 35 | 36 | (define/public (getvector) 37 | vect) 38 | (define/public (backto ref) 39 | (let* ([pos (remainder (+ head ref) vectlen)] 40 | [ret (remainder (+ (- tail pos) vectlen) vectlen)]) 41 | (set! tail pos) 42 | ret)) 43 | 44 | 45 | )) -------------------------------------------------------------------------------- /doc/doc.md: -------------------------------------------------------------------------------- 1 | lively-logic 2 | ============ 3 | 4 | 5 | 目录 6 | --------- 7 | 8 | 一、简介 9 | --------- 10 | 11 | lively-logic 是一个游戏逻辑实时调节框架，所谓实时调节，也就是在游戏程序运行的过程中调节游戏的逻辑。在源码中提供了框架本身和一个demo。 12 | 13 | lively-logic所使用的是racket语言，racket是一门动态语言，也是一门lisp语言，更是一门FP语言。racket的官方网站是： ，下载安装即可。racket有着非常丰富的文档，非常方便初学者学习。 14 | 15 | 二、概念 16 | ----------- 17 | 18 | ### 1、首先把游戏看做一个函数f。 19 | 20 | 这个函数的形式是： 21 | 22 | state -> dt -> events -> state 23 | 24 | 其中state表示游戏某一时刻的状态，dt表示状态更新的时间间隔，events表示dt内发生的事件，一般是用户输入的鼠标时间和键盘事件。 25 | 26 | 27 | 也就是： 28 | 29 | f(s,dt,e) = s' 30 | 31 | 假设有初始状态s0和事件e0,调用函数f，就能获得下一个状态s1，也即： 32 | 33 | f(s0,dt,e0) = s1 34 | 35 | 通过f和s0和用户的输入(e0,e1,e2....)可以得到一个状态序列 36 | 37 | s0 s1 s2 s3 s4.... 38 | 39 | 最后由观察者把这些状态表现出来。 40 | 41 | ### 2、f的特性。 42 | 43 | 一个纯粹的函数是指没有任何副作用的函数。副作用其实是指函数在其内部保存某种隐藏的状态。f是一个纯粹的函数， 44 | 也就是每次调用函数f，只要输入相同，输出一定相同。 45 | 46 | 相对于我们的游戏： 47 | 48 | f(s0,dt,e0) = s1 49 | f(s1,dt,e1) = s2 历史重演 50 | ... 51 | f(sn,dt,en) = sn+1 f(sn,dt,en) = sn+1 52 | f(sn+1,dt,en) = sn+2 f(sn+1,dt,en) = sn+2 53 | ... ... 54 | ... 55 | 也就是说在未来的某一时刻，可以让f重新作用于历史上的某一状态，能产生出相同的历史。这里重新作用于状态sn，从而让历史从sn处开始重演，但是历史没有改变。 56 | 57 | ### 3、时间 58 | 59 | 我们把f作用后所产生的状态称为当前，把之后将要产生的状态称为未来，之前的状态称为历史。也就是说我们的时间不只有向前流逝（让f作用于当前状态），我们可以让时间暂停（让f一直作用在当前的前一状态），或者重演历史（让f重新从历史上的某一个状态开始作用）。如果我们让f作用到历史上的某一时刻，那么这一时刻变成了当前，这一时刻之后的历史成为了未来。 60 | 61 | 向前流逝： 62 | 63 | s0 64 | s0 s1 65 | s0 s1 s2 66 | s0 s1 s2 s3 67 | s0 s1 s2 s3 s4 68 | ... 69 | 70 | 暂停： 71 | 72 | s0 73 | s0 s1 74 | s0 s1 75 | s0 s1 76 | ..... 77 | 78 | 重演历史： 79 | 80 | s0 81 | s0 s1 82 | s0 s1 s2 83 | s0 s1 s2 s3 84 | s0 s1 85 | s0 s1 s2 86 | s0 s1 s2 s3 87 | ..... 88 | 89 | ### 4、改变未来 90 | 91 | 当我们在当前时刻改变f为f'，意味着未来将会改变。 92 | 93 | ![change future](https://github.com/zanezhang/lively-logic/raw/master/doc/images/changefuture.png) 94 | 95 | ### 5、 改变历史 96 | 97 | 当我们把当前时刻回到历史上某一时刻，我们能够重演历史。当我们在当前时刻改变f'，我们能够改变未来。把两者结合，我们就能够改变历史。 98 | 99 | ![change history](https://github.com/zanezhang/lively-logic/raw/master/doc/images/changehistory.png) 100 | 101 | 三、具体实现 102 | ------------------------------- 103 | 104 | * 我们保存了历史上前一段时间的状态，所以我们能够重演历史。 105 | * demo是用racket写的。racket的eval函数可以在程序运行过程中可以动态编译运行代码。所以我们能够改变f，也就是能够改变未来。 106 | 107 | 重演历史+改变未来=改变历史 108 | 109 | 四、如何使用 110 | -------------------------------------- 111 | 112 | ### 1、源代码目录组织 113 | 114 | 源代码的目录组织如下： 115 | 116 | .\ 117 | 118 | .\demo 119 | 120 | .\doc 121 | 122 | .\src 123 | 124 | .\README.md 125 | 126 | .\AUTHORS 127 | 128 | 其中demo目录下包含了一个使用此框架的游戏demo；doc目录下是此框架的文档信息；src目录下是此框架的源码。 129 | 130 | ### 2、demo 131 | 132 | 如果你只想看看这是一个什么东西，那么请用racket打开demo目录下的pallet-game.rkt文件，然后运行即可。 133 | 134 | 如果你想使用我们的框架，那么你也可以参考demo的代码。 135 | 136 | ### 3、快捷键 137 | 138 | 这里所指的快捷键是指当键盘输入焦点在游戏的canvas上时，用户输入的快捷键。 139 | 140 | ctrl+p 暂停游戏。 141 | 142 | ctrl+c 继续游戏。 143 | 144 | ctrl+t 显示或者关闭轨迹，在游戏暂停时才有效。 145 | 146 | ### 4、滑动条 147 | 148 | 当游戏暂停时，通过拖动滑动条，可以达到历史上的某一时刻。 149 | 150 | ### 5、编辑器 151 | 152 | 编辑器内为游戏主逻辑函数的代码，可以在游戏运行过程中或者暂停时，实时改变代码，从而达到立即改变游戏逻辑的目的。 153 | 154 | ### 6、框架类 155 | 156 | lively-logic框架通过一个类提供接口，这个类的类名为myframework%，在文件framework.rkt中定义。 157 | 158 | myframework% : class? 159 | superclass : onject% 160 | 161 | 一个myframework%对象定义了游戏运行的一种机制，只要对象初始化的时候传入适当的参数，游戏就能运，并且能够方便的调节游戏参数。 162 | 163 | (new myframework% [itv itv] 164 | [mainf mainf] 165 | [showf showf] 166 | [drawpointf drawpointf] 167 | [inits inits] 168 | [copystate copystate] 169 | [keyeventfilter keyeventfilter] 170 | [mouseeventfilter mouseeventfilter]) 171 | -> (is-a?/c myframework%) 172 | 173 | 此函数用来创建一个myframework%对象。其中itv表示游戏逻辑帧的时间间隔，也就是1/itv为逻辑帧的帧率。 174 | 175 | mainf是一个字符串，表示游戏逻辑函数mainloop的代码所在的文件。框架运行后，文件内的代码将被求值为一个lambda表达式，作为游戏的逻辑函数。同时代码将在编辑框中显示，可在游戏运行过程中动态的修改代码。函数mainloop的形式是： 176 | 177 | (lambda (dt eventlist state) 178 | ...) 179 | ->state 180 | 181 | showf是一个lambda表达式，用来向canvas绘制整个游戏。每次逻辑更新后，也即调用mainloop函数后，showf将会被调用，来显示新的一帧游戏画面。showf的形式是： 182 | 183 | (lambda (dc state) 184 | ...) 185 | ->any/c 186 | 187 | drawpointf是一个lambda表达式，用来向canvas绘制游戏中某些对象的轨迹。当游戏暂停时，此函数会被调用来绘制轨迹，从而方便调节游戏参数。drawpointf的形式是： 188 | 189 | (lambda (dc state) 190 | ...) 191 | ->any/c 192 | 193 | inits是游戏的初始状态，类型为用户自定义。 194 | 195 | copystate是一个lambda表达式，用来拷贝游戏状态。用户可以通过定义这个函数来自定义游戏状态的拷贝方式。copystate的形式是： 196 | 197 | (lambda (state) 198 | ...) 199 | ->state 200 | 201 | keyeventfilter是一个lambda表达式，用来过滤键盘输入事件。当lively-logic框架接收到键盘事件，且焦点在canvas上时，键盘事件通过keyeventfilter过滤后放入eventlist中，在下一次逻辑更新时使用，当keyeventfilter返回#f时，表示这个事件被抛弃。keyeventfilter的形式是: 202 | 203 | (lambda (event) 204 | ...) 205 | ->(or/c (any/c) (#f)) 206 | 207 | mouseeventfilter是一个lambda表达式，用来过滤鼠标输入事件。当lively-logic框架的canvas接收到鼠标事件时，鼠标事件通过mouseeventfilter过滤后放入eventlist中，在下一次逻辑更新时使用，当mouseeventfilter返回#f时，表示这个事件被抛弃。mouseeventfilter的形式是: 208 | 209 | (lambda (event) 210 | ...) 211 | ->(or/c (any/c) (#f)) 212 | 213 | 下面是这个类所提供的接口： 214 | 215 | (send a-framework run) -> any/c 216 | 217 | 此函数用来启动框架。 218 | 219 | (send a-framework recaculate) -> any/c 220 | 221 | 此函数强迫框架重新计算。 222 | 223 | -------------------------------------------------------------------------------- /demo/collisiondetect.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (struct posn (x y [z #:auto]) 4 | #:auto-value 0 5 | #:transparent 6 | #:mutable) 7 | 8 | (define (xmult p1-x p1-y p2-x p2-y p3-x p3-y) 9 | (-(*(- p1-x p3-x) (- p2-y p3-y)) (*(- p2-x p3-x)(- p1-y p3-y)))) 10 | (define (mymult p1-x p1-y p2-x p2-y p-x p-y) 11 | (-(*(- p1-y p2-y) (- p-x p1-x)) (*(- p1-x p2-x)(- p-y p1-y)))) 12 | (define sameside 13 | (lambda (f l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y) 14 | (cond [(> (* (f l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y) 15 | (f l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p2-x l2-p2-y)) 0) 16 | #t] 17 | [else #f]))) 18 | (define intersect-in 19 | (lambda (l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y) 20 | (and (not (sameside mymult l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y)) 21 | (not (sameside mymult l2-p1-x l2-p1-y l2-p2-x l2-p2-y l1-p1-x l1-p1-y l1-p2-x l1-p2-y))))) 22 | (define intersect 23 | (lambda (l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y) 24 | (let ([tt (-(*(- l1-p1-x l1-p2-x) (- l2-p1-y l2-p2-y)) (* (- l1-p1-y l1-p2-y) (- l2-p1-x l2-p2-x)))]) 25 | (cond [(= tt 0) #f] 26 | [else 27 | (let* ([t (/(-(*(- l1-p1-x l2-p1-x) (- l2-p1-y l2-p2-y)) (* (- l1-p1-y l2-p1-y) (- l2-p1-x l2-p2-x))) tt)] 28 | [x (+ l1-p1-x (* (- l1-p2-x l1-p1-x) t))] 29 | [y (+ l1-p1-y (* (- l1-p2-y l1-p1-y) t))]) 30 | (posn x y))])))) 31 | 32 | (define detect-two-line-cross 33 | (lambda (l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y) 34 | (cond [(intersect-in l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y) 35 | (intersect l1-p1-x l1-p1-y l1-p2-x l1-p2-y l2-p1-x l2-p1-y l2-p2-x l2-p2-y)] 36 | [else #f]))) 37 | (struct line (x1 y1 x2 y2 direct) 38 | #:transparent 39 | #:mutable) 40 | (struct rect (x y width height) 41 | #:transparent 42 | #:mutable) 43 | (provide line) 44 | (provide line-direct) 45 | (provide line-x2) 46 | (provide line-y2) 47 | (define goback 48 | (lambda (l2 l1) 49 | (let ([pos (detect-two-line-cross (line-x1 l1) (line-y1 l1) (line-x2 l1) (line-y2 l1)(line-x1 l2) (line-y1 l2) (line-x2 l2) (line-y2 l2))]) 50 | (cond [pos 51 | ;(case (line-direct l2) 52 | ; [(0 3) (line (line-x1 l1) (line-y1 l1) (line-x2 l1) (posn-y pos) (line-direct l2))] 53 | ;[(1 2) (line (line-x1 l1) (line-y1 l1) (posn-x pos) (line-y2 l1) (line-direct l2))]) 54 | (line (line-x1 l1) (line-y1 l1) (posn-x pos) (posn-y pos) (line-direct l2)) 55 | ] 56 | [else 57 | l1])))) 58 | 59 | (define (merge-rect up1 left1 right1 down1 up2 left2 right2 down2) 60 | (let ([up 61 | (if (< up1 up2) up1 up2)] 62 | [left 63 | (if (< left1 left2) left1 left2)] 64 | [right 65 | (if (< right1 right2) right2 right1)] 66 | [down 67 | (if (< down1 down2) down2 down1)]) 68 | (begin 69 | ;(printf "merge-rect") 70 | (rect left up (- right left) (- down up))))) 71 | ;(define (detect-collision-barrier-iner x y vect tile-width tile-height tile-step) 72 | ; (let ([ref-num (inexact->exact (+ (floor (/ x tile-width)) (* (floor (/ y tile-height)) tile-step)))]) 73 | ; (cond 74 | ; [(> (vector-ref vect ref-num) 0) ref-num] 75 | ; [else #false]))) 76 | (define line-offset 77 | (lambda (l x y) 78 | (line (+ x (line-x1 l)) (+ y (line-y1 l))(+ x (line-x2 l))(+ y (line-y2 l))(line-direct l)))) 79 | (define getlinelist 80 | (lambda (x y width height vect tile-width tile-height tile-step) 81 | (let ([linelist '()] 82 | [vectlength (vector-length vect)] 83 | [foo (lambda (up left right down) 84 | (list (line left up right up 0) (line left up left down 1)(line right up right down 2)(line left down right down 3)))]) 85 | (begin 86 | (for ([i (in-range (floor (/ x tile-width)) (+ (floor (/ (+ x width) tile-width)) 1))]) 87 | (for ([j (in-range (floor (/ y tile-height)) (+ (floor (/ (+ y height) tile-height))1))]) 88 | (let ([ref (inexact->exact (+ i (* j tile-step)))]) 89 | (cond 90 | [(and (< ref vectlength)(>= ref 0) (> (vector-ref vect ref) 0)) 91 | (begin 92 | ;(printf "youxi") 93 | (set! linelist (append (foo (* j tile-height)(* i tile-width)(+ (* i tile-width) tile-width -1)(+ (* j tile-height) tile-height -1)) linelist)))])))) 94 | ; (printf "getlinelist : ~a" linelist) 95 | linelist)))) 96 | (define (detect-collision-barrier x y width height offset-x offset-y vect tile-width tile-height tile-step mapwidth mapheight) 97 | (let* ([mrect (merge-rect y x (+ x width) (+ y height) (+ y offset-y)(+ x offset-x) (+ x offset-x width)(+ y offset-y height))] 98 | [linlist (getlinelist (rect-x mrect) (rect-y mrect)(rect-width mrect)(rect-height mrect) vect tile-width tile-height tile-step)] 99 | [myline (line x y (+ x offset-x) (+ y offset-y) -1) ]) 100 | (begin 101 | ;(printf "rect: ~a" mrect) 102 | (set! linlist (append linlist (list (line -1 -1 mapwidth -1 3) (line -1 -1 -1 mapheight 2)(line mapwidth -1 mapwidth mapheight 1)(line mapwidth mapheight -1 mapheight 0)))) 103 | (set! myline (foldr goback myline linlist)) 104 | (set! myline (line-offset myline width 0)) 105 | (set! myline (foldr goback myline linlist)) 106 | (set! myline (line-offset myline 0 height)) 107 | (set! myline (foldr goback myline linlist)) 108 | (set! myline (line-offset myline (- 0 width) 0)) 109 | (set! myline (foldr goback myline linlist)) 110 | (set! myline (line-offset myline 0 (- 0 height))) 111 | (line (line-x1 myline) (line-y1 myline) (- (line-x2 myline) (/ offset-x 1000000))(- (line-y2 myline)(/ offset-y 1000000)) (line-direct myline)) 112 | 113 | ))) 114 | (define (detect-collision-rect x y width height offset-x offset-y x1 y1 width1 height1) 115 | (let* ([linlist (list (line x1 y1 (+ x1 width1) y1 0) 116 | (line x1 y1 x1 (+ height1 y1) 1) 117 | (line (+ x1 width1) y1 (+ x1 width1)(+ y1 height1) 2) 118 | (line (+ x1 width1)(+ y1 height1)x1 (+ y1 height1) 3))] 119 | [myline (line x y (+ x offset-x) (+ y offset-y) -1)]) 120 | (begin 121 | ;(printf "~a ~a ~a ~a ~a ~a ~a ~a ~a ~a \n" x y width height offset-x offset-y x1 y1 width1 height1) 122 | (set! myline (foldr goback myline linlist)) 123 | (set! myline (line-offset myline width 0)) 124 | (set! myline (foldr goback myline linlist)) 125 | (set! myline (line-offset myline 0 height)) 126 | (set! myline (foldr goback myline linlist)) 127 | (set! myline (line-offset myline (- 0 width) 0)) 128 | (set! myline (foldr goback myline linlist)) 129 | (set! myline (line-offset myline 0 (- 0 height))) 130 | (line (line-x1 myline) (line-y1 myline) (- (line-x2 myline) (/ offset-x 1000000))(- (line-y2 myline)(/ offset-y 1000000)) (line-direct myline)) 131 | ))) 132 | (define rect-intersection 133 | (lambda (up1 left1 right1 down1 up2 left2 right2 down2) 134 | (cond 135 | [(or (< down1 up2) (< down2 up1) (< right2 left1) (< right1 left2)) 136 | #false] 137 | [else #true]))) 138 | (provide rect-intersection) 139 | (provide detect-collision-rect) 140 | (provide detect-collision-barrier) 141 | 142 | -------------------------------------------------------------------------------- /demo/pallet-game.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require framework) 3 | (require racket/match) 4 | (require "xml-map.rkt") 5 | (require "../src/framework/framework.rkt") 6 | (require "collisiondetect.rkt") 7 | 8 | (define vect-list (read-map-xml "2.tmx")) 9 | (define barrier-vect (car vect-list));储存砖块信息 10 | (define myforegmap (read-bitmap "brick.png")) 11 | (define mariomap(read-bitmap "mario-small.png")) 12 | (define mariomap2 (read-bitmap "mario-small2.png")) 13 | (define mariogirlmap(read-bitmap "m-gz.png")) 14 | (define marioxxmap(read-bitmap "m-xx.png")) 15 | (define wgmap (read-bitmap "yazi.png")) 16 | (define map-width 600) 17 | (define map-height 700) 18 | (define tile-width 50) 19 | (define tile-height 50) 20 | (define tile-step 12) 21 | (struct state (x y d m v-x v-y r die win pitui cr cg cb csize totaltime tx ) 22 | #:transparent 23 | #:mutable) 24 | (struct tortoise (x y d stop time pitui) 25 | #:transparent 26 | #:mutable) 27 | (define mario-state (state 1 1 0 0 0 0 0 0 0 0 0 0 0 100 0 (tortoise 220 504 1 0 -1 0 ))) 28 | (define (draw-point dc mario-s) 29 | (send dc draw-bitmap-section mariomap 30 | (state-x mario-s) (state-y mario-s) 31 | (* (state-m mario-s) 41) 32 | (* (state-d mario-s) 40) 38 38)) 33 | (define mef 34 | (lambda (event) 35 | (cond 36 | [(and (send event button-down? 'left)(send event get-control-down)) 37 | (let ([x (send event get-x)] 38 | [y (send event get-y)]) 39 | (begin 40 | (change-barrier x y 1) 41 | #f))] 42 | [(and (send event button-down? 'right)(send event get-control-down)) 43 | (let ([x (send event get-x)] 44 | [y (send event get-y)]) 45 | (begin 46 | (change-barrier x y 0) 47 | #f))] 48 | [(and (send event dragging?)(send event get-left-down)(send event get-control-down)) 49 | (let ([x (send event get-x)] 50 | [y (send event get-y)]) 51 | (begin 52 | (change-barrier x y 1) 53 | #f))] 54 | [(and (send event dragging?)(send event get-right-down)(send event get-control-down)) 55 | (let ([x (send event get-x)] 56 | [y (send event get-y)]) 57 | (begin 58 | (change-barrier x y 0) 59 | #f))] 60 | [else #f] 61 | ))) 62 | (define kef 63 | (lambda (event) 64 | (let([key (send event get-key-code)] 65 | [releasekey (send event get-key-release-code)] 66 | [parse (lambda (type cmd) 67 | (cond 68 | [(symbol=? type 'press) 69 | (cond 70 | [(char? cmd) 71 | (let ([tempcmd (char-downcase cmd)]) 72 | (case tempcmd 73 | [(#\space)(list 'jump)] 74 | [else #f]))] 75 | [(symbol? cmd) 76 | (cond 77 | [(symbol=? cmd 'left)(list 'left 'down)] 78 | [(symbol=? cmd 'right)(list 'right 'down)] 79 | [else #f])])] 80 | [(symbol=? type 'release) 81 | (cond 82 | [(char? cmd) #f] 83 | [(symbol? cmd) 84 | (cond 85 | [(symbol=? cmd 'left)(list 'left 'release)] 86 | [(symbol=? cmd 'right)(list 'left 'release)] 87 | [else #f] 88 | )])]))]) 89 | (cond 90 | [(and (key-code-symbol? key) (symbol=? key 'release)) 91 | (parse 'release releasekey)] 92 | [else (parse 'press key)])))) 93 | 94 | (define change-barrier 95 | (lambda (x y amt) 96 | (let ([ref-num (+ (* tile-step (floor (/ y tile-height))) (floor (/ x tile-width)))]) 97 | (begin 98 | (vector-set! (car vect-list) ref-num amt) 99 | (send mario-example recalculate) 100 | )))) 101 | 102 | 103 | (define mydisplay 104 | (lambda (dc mario-s) 105 | (cond [mario-s 106 | (begin 107 | (define draw-mario 108 | (lambda (dc) 109 | (cond [(= 0 (state-r mario-s)) 110 | (send dc draw-bitmap-section mariomap 111 | (state-x mario-s) (state-y mario-s) 112 | (* (state-pitui mario-s) 41) 113 | (* (state-d mario-s) 40) 38 38)] 114 | [else 115 | (send dc draw-bitmap-section mariomap2 116 | (state-x mario-s) (state-y mario-s) 117 | (* (- 1 (state-pitui mario-s)) 41) 118 | (* (state-d mario-s) 40) 38 38)]))) 119 | 120 | (define draw-foreg 121 | (lambda (dc vect map) 122 | (let* ([draw-one-iner (lambda (dc type loc) 123 | (let ([x (* (remainder loc (/ map-width tile-width)) tile-width)] 124 | [y (* (quotient loc (/ map-width tile-width)) tile-height)]) 125 | (cond 126 | [(> type 0) (send dc draw-bitmap-section map x y 1 0 tile-width tile-height)])))]) 127 | (let loop ([n 0]) 128 | (cond 129 | [(< n (/ (* map-width map-height) (* tile-width tile-height))) 130 | (begin 131 | (draw-one-iner dc (vector-ref vect n) n) 132 | (loop (add1 n)))])) 133 | ))) 134 | (define (draw-wugui dc) 135 | (let ([pos 0] 136 | [tx (state-tx mario-s)]) 137 | (begin 138 | (cond 139 | [(= (tortoise-stop tx) 1) 140 | (set! pos 0)] 141 | [(= (tortoise-d tx) -1) 142 | (set! pos (+ 1 (tortoise-pitui tx)))] 143 | [(= (tortoise-d tx) 1) 144 | (set! pos (+ 3 (tortoise-pitui tx)))]) 145 | (send dc draw-bitmap-section wgmap (tortoise-x (state-tx mario-s)) (tortoise-y (state-tx mario-s)) (* pos 40) 0 40 46)))) 146 | (define (draw-win dc) 147 | (begin 148 | ;(send dc set-rotation (* 180 (cos(sin (/ (state-totaltime mario-s)108))))) 149 | (send dc set-font (make-object font% (state-csize mario-s) 'roman)) 150 | (send dc set-text-foreground (make-object color% (state-cr mario-s)(state-cg mario-s)(state-cb mario-s))) 151 | (let-values ([(w h a b)(send dc get-text-extent "win!")]) 152 | (send dc draw-text "win!" (- 300 (/ w 2))(- 300 (/ h 2)))) 153 | ;(send dc set-rotation 0) 154 | )) 155 | 156 | 157 | (send dc draw-rectangle 0 0 600 700) 158 | (draw-foreg dc barrier-vect myforegmap) 159 | (send dc draw-bitmap-section mariogirlmap 520 450 0 0 50 50) 160 | (send dc draw-bitmap-section marioxxmap 420 260 0 0 50 50) 161 | (draw-wugui dc) 162 | (draw-mario dc) 163 | (cond 164 | [(= 1 (state-win mario-s)) 165 | (draw-win dc)]) 166 | )]))) 167 | 168 | 169 | (define state-copy 170 | (lambda (x) 171 | (begin 172 | (define ret(struct-copy state x)) 173 | (set-state-tx! ret (struct-copy tortoise (state-tx x))) 174 | ret))) 175 | 176 | (define mario-example (new myframework% [itv 30][mainf "editor1.txt"][showf mydisplay][drawpointf draw-point][inits mario-state] 177 | [copystate state-copy] 178 | [keyeventfilter kef] 179 | [mouseeventfilter mef])) 180 | (send mario-example run) 181 | 182 | 183 | 184 | 185 | 186 | 187 | -------------------------------------------------------------------------------- /demo/editor1.txt: -------------------------------------------------------------------------------- 1 | (lambda (interv eventlist mario-s) 2 | (begin 3 | (let*([mario-x (state-x mario-s)] 4 | [mario-y (state-y mario-s)] 5 | [mario-m (state-m mario-s)] 6 | [mario-d (state-d mario-s)] 7 | [mario-die (state-die mario-s)] 8 | [tt (+ (state-totaltime mario-s)interv)] 9 | [tx (state-tx mario-s)] 10 | [g 0.4];重力加速度 11 | [a 1] 12 | [v-x (state-v-x mario-s)] 13 | [v-y (+ (state-v-y mario-s) (* g interv))] 14 | [ontheroad #f] 15 | [onthetortoise #f] 16 | [imdie #f] 17 | [wantjump #f] 18 | [temp-y (/(* v-y interv)1000)] 19 | [temp-x (/(* v-x interv)1000)] 20 | [move-line-y 0] 21 | [move-line-x 0] 22 | [move-line 0]) 23 | (define change-direction 24 | (lambda(x) 25 | (begin 26 | (set! mario-m 1) 27 | ; (printf "change d") 28 | (set! mario-d x)))) 29 | (define direction-key-release 30 | (lambda(x) 31 | (set! mario-m 0))) 32 | (define event-handler 33 | (lambda (e) 34 | (cond 35 | [(symbol=? 'jump (car e)) 36 | (set! wantjump #t)] 37 | [(symbol=? 'left (car e)) 38 | (cond [(symbol=? 'down (cadr e)) 39 | (change-direction 1)] 40 | [else (direction-key-release 1)])] 41 | [(symbol=? 'right (car e)) 42 | (cond [(symbol=? 'down (cadr e)) 43 | (change-direction 0)] 44 | [else (direction-key-release 0)])]))) 45 | (define dologic 46 | (lambda () 47 | (begin 48 | (set! move-line-y (detect-collision-barrier mario-x mario-y 38 38 0 temp-y 49 | barrier-vect tile-width tile-height 50 | tile-step map-width (+ map-height 40))) 51 | (set! move-line-x (detect-collision-barrier mario-x (line-y2 move-line-y) 38 38 52 | temp-x 0 barrier-vect tile-width 53 | tile-height tile-step map-width 54 | (+ map-height 40))) 55 | (set! move-line (detect-collision-rect mario-x mario-y 38 38 56 | (- (line-x2 move-line-x) mario-x) 57 | (- (line-y2 move-line-x) mario-y) 58 | (tortoise-x tx)(+ (tortoise-y tx)20) 40 26)) 59 | 60 | (case (line-direct move-line-y) 61 | [(0) ;up 62 | (cond 63 | [(> g 0) 64 | (begin 65 | (set! ontheroad #t) 66 | (set! v-y 0))] 67 | [else 68 | (begin 69 | (set! v-y (* (- 0 v-y) 0.5)))] 70 | )] 71 | [(3);down 72 | (cond 73 | [(< g 0) 74 | (begin 75 | (set! ontheroad #t) 76 | (set! v-y 0))] 77 | [else 78 | (begin 79 | (set! v-y (* (- 0 v-y) 0.5)))] 80 | )] 81 | ) 82 | (case (line-direct move-line-x) 83 | [(1 2);left right 84 | (cond [(not ontheroad) 85 | ;(set-state-d! mario-s (- 1 (state-d mario-s))) 86 | (set! v-x (* (- 0 v-x) 0.5))])] 87 | ) 88 | (case (line-direct move-line) 89 | [(0) ;up 90 | (begin 91 | (set! onthetortoise #t) 92 | )] 93 | [(1 2 3) ;up 94 | (begin 95 | (set! imdie #t) 96 | )] 97 | [else 98 | (cond 99 | [(rect-intersection mario-y mario-x (+ mario-x 38)(+ mario-y 38) 100 | (+(tortoise-y tx)20) (tortoise-x tx) 101 | (+ 40 (tortoise-x tx))(+ 46 (tortoise-y tx))) 102 | (set! imdie #t)])] 103 | ) 104 | (map event-handler eventlist) 105 | (cond 106 | [(or ontheroad) 107 | (cond 108 | [(= 1 mario-m) 109 | (set! v-x (* (- 0.5 (state-d mario-s)) 250))] 110 | [else 111 | (set! v-x 0)])]) 112 | (cond 113 | [(and ontheroad wantjump) 114 | (cond 115 | [(> g 0) 116 | (set! v-y -300)];在平地上起跳的初速度 117 | [else 118 | (set! v-y 300)])]) 119 | (cond 120 | [imdie 121 | (begin 122 | (set-state-die! mario-s 1) 123 | (set! v-x 0) 124 | (set! v-y -150))]) 125 | ;跳到乌龟上 126 | (cond 127 | [(and onthetortoise) 128 | (begin 129 | (set! v-y -500);跳到乌龟上的反弹速度 130 | (set-tortoise-stop! tx 1) 131 | (set-tortoise-time! tx 3000) 132 | (cond 133 | [(= mario-m 0) 134 | (set! v-x 0) ] 135 | [(= 0 v-x) 136 | (set! v-x (* (- 0.5 (state-d mario-s)) 250))]) 137 | )]) 138 | (cond 139 | [(and ontheroad (= mario-m 1)) 140 | (set-state-pitui! mario-s (remainder (floor (/ tt 150)) 2))] 141 | [else 142 | (set-state-pitui! mario-s 0)]) 143 | 144 | 145 | (set-state-win! mario-s 0) 146 | (cond 147 | [(and ontheroad (rect-intersection mario-y mario-x (+ mario-x 38)(+ mario-y 38) 148 | 450 520 570 500)) 149 | (set-state-win! mario-s 1)]) 150 | 151 | (set! mario-x (line-x2 move-line)) 152 | (set! mario-y (line-y2 move-line)) 153 | ))) 154 | 155 | (cond 156 | [(and (= mario-die 0)) 157 | (begin 158 | (define bound 159 | (lambda (min max amt) 160 | (cond 161 | [(< amt min) min] 162 | [(> amt max) max] 163 | [else amt]))) 164 | (dologic) 165 | (cond 166 | [(= 1 (state-win mario-s)) 167 | (begin 168 | ;(printf "qqsd") 169 | ;下面这一坨来调节win的颜色和大小，依次为r g b size 170 | (set-state-cr! mario-s (bound 0 255(inexact->exact (floor(+ 128 (* 127 (sin (/ tt 160)))))))) 171 | (set-state-cg! mario-s (bound 0 255(inexact->exact (floor(+ 128 (* 127 (cos (/ tt 99)))))))) 172 | (set-state-cb! mario-s (bound 0 255(inexact->exact (floor(+ 128 (* 127 (sin (/ tt 20)))))))) 173 | (set-state-csize! mario-s (bound 10 1000(inexact->exact (floor(+ 100(* 20 (sin (/ tt 599)))))))))]))] 174 | [(= mario-die 1 ) 175 | (begin 176 | (set! mario-x (+ mario-x temp-x)) 177 | (set! mario-y (+ mario-y temp-y)))]) 178 | 179 | ;乌龟逻辑 180 | (define (do-wugui-logic) 181 | (let ([base-x 200] 182 | [diff 0] 183 | [offset 20]) 184 | (begin 185 | (cond 186 | [(= (tortoise-stop tx) 0) 187 | (begin 188 | ;下面这句话能让乌龟动起来 189 | ; (set! diff (*(tortoise-d tx) interv 0.03)) 190 | (set-tortoise-x! tx (+ (tortoise-x tx) diff)) 191 | (set-tortoise-pitui! tx (remainder (floor (/ (abs (tortoise-x tx)) 11)) 2)) 192 | )] 193 | [else 194 | (begin 195 | (set-tortoise-time! tx (- (tortoise-time tx) interv)) 196 | (cond 197 | [(< (tortoise-time tx) 0) 198 | (set-tortoise-stop! tx 0)]))]) 199 | (cond 200 | [(> (- (tortoise-x tx) base-x) offset) 201 | (begin 202 | (set-tortoise-x! tx(+ base-x offset)) 203 | (set-tortoise-d! tx (- 0 (tortoise-d tx))))] 204 | [(> (- base-x (tortoise-x tx)) offset) 205 | (begin 206 | (set-tortoise-x! tx (- base-x offset)) 207 | (set-tortoise-d! tx (- 0 (tortoise-d tx))))])))) 208 | ;;;;;;;;;;;;;;;; 209 | (do-wugui-logic) 210 | 211 | (set-state-totaltime! mario-s tt) 212 | (set-state-m! mario-s mario-m) 213 | (set-state-d! mario-s mario-d) 214 | (set-state-v-x! mario-s v-x) 215 | (set-state-v-y! mario-s v-y) 216 | (set-state-x! mario-s mario-x) 217 | (set-state-y! mario-s mario-y) 218 | (set-state-r! mario-s 219 | (cond 220 | [(> g 0) 221 | 0] 222 | [else 1])) 223 | (cond [(> (state-y mario-s) map-height) 224 | (begin 225 | (set! mario-s (state 1 1 0 0 0 0 0 0 0 0 0 0 0 100 tt tx)) 226 | )])) 227 | mario-s)) -------------------------------------------------------------------------------- /src/framework/framework.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require framework) 3 | (require "time-interval.rkt") 4 | (require "statevect.rkt") 5 | (struct sexp-st (start end sexp) 6 | #:transparent 7 | #:mutable) 8 | (provide myframework%) 9 | (define myframework% 10 | (class object% 11 | (init itv mainf showf drawpointf inits copystate keyeventfilter mouseeventfilter) ; initialization argument 12 | ; field 13 | (define mainfstring mainf);主循环所在文件的文件名 14 | (define showfun showf);显示函数，用来向canvas输出 15 | (define timeinteval itv);游戏每帧的间隔 16 | (define drawpointfun drawpointf);用来向canvas输出轨迹 17 | (define track-state 0);是否画轨迹的标记 18 | (define nowstate #f) 19 | (define ispause #f) 20 | (define statelen 133);录像的长度 21 | (define myinitstate inits);游戏的初始状态 22 | (define mykeyeventfilter keyeventfilter);键盘事件过滤器 23 | (define mymouseeventfilter mouseeventfilter);鼠标事件过滤器 24 | (define mycopystate copystate);游戏状态的copy函数 25 | (define get-interval (make-interval));获取时间间隔 26 | (define statequeue (new vectmanager% [length statelen][val myinitstate]));游戏状态队列 27 | (define eventqueue (new vectmanager% [length statelen][val '()]));事件队列 28 | (define eventlist '()) 29 | (define initcomplete #f) 30 | (define editor-change #f) 31 | (define canvas-on-focus #f) 32 | (define focus-pen 33 | (new pen% [color (make-object color% 0 255 0)] 34 | [width 3] 35 | [style 'solid])) 36 | (define non-focus-pen 37 | (new pen% [color (make-object color% 255 255 255)] 38 | [width 2] 39 | [style 'solid])) 40 | (define mainloop 41 | (lambda (x y z) 42 | (void)));游戏主循环 43 | (define my-frame% 44 | (class frame% 45 | (super-new) 46 | (define/augment (on-close) 47 | (cond [(and editor-change (symbol=? 'yes (message-box """代码已被修改，是否保存?" #f (list 'yes-no)))) 48 | (send mytext save-file)])))) 49 | (define myframe (new my-frame% [label "game-editor"] 50 | [width 1200] 51 | [height 800])) 52 | (define v-panel (new vertical-panel% [parent myframe])) 53 | (define h-panel (new horizontal-panel% [parent v-panel][ stretchable-height #f])) 54 | (define slider-cb 55 | (lambda (b e) 56 | (let* ([ref (send b get-value)] 57 | [c-s (send statequeue getdata ref)]) 58 | (begin 59 | (set! nowstate c-s) 60 | (send game-canvas on-paint) 61 | ; (showoncanvas c-s) 62 | ;(cond [(= track-state 1) 63 | ;(draw-track)]) 64 | )))) 65 | (define draw-track 66 | (lambda () 67 | (let* ([dc (send game-canvas get-dc)] 68 | [draw-point-inner 69 | (let ([num 0]) 70 | (lambda (c-s) 71 | (begin 72 | (cond [(and c-s (= 0 (remainder num 5))) 73 | (drawpointfun dc c-s)]) 74 | (set! num (add1 num)))))]) 75 | (begin 76 | (send dc suspend-flush) 77 | (send dc set-alpha 0.2) 78 | (vector-map draw-point-inner (send statequeue getvector)) 79 | (send dc set-alpha 1) 80 | (send dc resume-flush))))) 81 | (define myslider (new slider% 82 | [label "&slider"] 83 | [min-value 0] 84 | [max-value (- statelen 1)] 85 | [init-value (- statelen 1)] 86 | [parent h-panel] 87 | [enabled #f] 88 | [callback slider-cb])) 89 | 90 | (define mypanel (new horizontal-panel% [parent v-panel])) 91 | 92 | (define pause 93 | (lambda () 94 | (begin 95 | (send maintimer stop) 96 | (send myslider set-value (- statelen 1)) 97 | (set! ispause #t) 98 | (send game-canvas on-paint) 99 | (send myslider enable #t)))) 100 | (define continue 101 | (lambda () 102 | (begin 103 | (send playtimer start timeinteval) 104 | ))) 105 | (define track 106 | (lambda () 107 | (begin 108 | (set! track-state (- 1 track-state)) 109 | (cond 110 | [(> track-state 0) 111 | (draw-track)]) 112 | ))) 113 | (define playtimer 114 | (new timer% 115 | [interval #f] 116 | [notify-callback 117 | (lambda () 118 | (let ([ref (send myslider get-value)]) 119 | (cond [(= ref (- statelen 1)) 120 | (begin 121 | (send playtimer stop) 122 | (send myslider enable #f) 123 | (set! get-interval (make-interval)) 124 | (set! ispause #f) 125 | (send maintimer start timeinteval))] 126 | [else 127 | (begin 128 | 129 | (send myslider set-value (+ ref 1)) 130 | (slider-cb myslider 'slider))])))])) 131 | (define my-canvas% 132 | (class canvas% 133 | (super-new) 134 | (define/override (on-char event) 135 | (begin 136 | (let([key (send event get-key-code)]) 137 | (cond 138 | [(char? key) 139 | (case key 140 | [(#\p) (pause)] 141 | [(#\c) (continue)] 142 | [(#\t) (track)])]))) 143 | (let ([e (mykeyeventfilter event)]) 144 | (cond [e (set! eventlist (append eventlist (list e) ))]))) 145 | (define/override (on-event event) 146 | (let ([e (mymouseeventfilter event)]) 147 | (cond [e (set! eventlist (append eventlist (list e) ))]))) 148 | (define/override (on-paint) 149 | (begin 150 | ;(printf "onpaint") 151 | (showoncanvas nowstate) 152 | (cond [(and (= track-state 1) ispause) 153 | (draw-track)]) 154 | )) 155 | 156 | (define/override (on-focus on?) 157 | (begin 158 | (set! canvas-on-focus on?) 159 | (send this on-paint) 160 | ;(display canvas-on-focus) 161 | )))) 162 | (define game-canvas (new my-canvas% [parent mypanel] )) 163 | (define showoncanvas 164 | (lambda (s) 165 | (let ([dc (send game-canvas get-dc)]) 166 | (let-values ([(w h)(send game-canvas get-size)]) 167 | (send dc suspend-flush) 168 | (send dc erase) 169 | (send dc draw-rectangle 0 0 w h) 170 | (showfun dc s) 171 | (define oldpen (send dc get-pen)) 172 | (cond 173 | [canvas-on-focus 174 | (send dc set-pen focus-pen)] 175 | [else 176 | (send dc set-pen non-focus-pen)]) 177 | (send dc draw-line 0 0 0 h) 178 | (send dc draw-line 0 0 w 0) 179 | (send dc draw-line w h w 0) 180 | (send dc draw-line w h 0 h) 181 | (send dc set-pen oldpen) 182 | (send dc resume-flush) 183 | 184 | )))) 185 | (define editor-panel (new vertical-panel% [parent mypanel])) 186 | (define editor-canvas (new editor-canvas% [parent editor-panel])) 187 | ; (define outputmsg (new message% [label "sss" ] [parent editor-panel][min-height 150][stretchable-height #f])) 188 | (define output-canvas (new editor-canvas% [parent editor-panel][min-height 150][stretchable-height #f])) 189 | (define my-text% 190 | (class racket:text% 191 | (super-new) 192 | (define/override (on-char event) 193 | (let([key (send event get-key-code)] 194 | [cd (send event get-control-down)]) 195 | (begin 196 | (cond 197 | [;(and cd (char? key)(char-ci=? key #\m)) 198 | (and (symbol? key)(symbol=? key 'escape)) 199 | (do-adjust)] 200 | [else (super on-char event)])))) 201 | (define/augment (on-change) 202 | (begin 203 | (set! editor-change #t) 204 | (with-handlers ([exn:fail? (lambda (exn) (outputerror exn))]) 205 | ; (printf "change1\n") 206 | (set! mainloop (test (send this get-text))) 207 | ; (printf "change2\n") 208 | (recalculate) 209 | (outputsuccess) 210 | )) 211 | ))) 212 | 213 | 214 | 215 | 216 | (define (get-out-exp) 217 | (let* ([posnow (send mytext get-start-position)] 218 | [posstart (send mytext find-up-sexp posnow)]) 219 | (cond [posstart 220 | (let ([posend (send mytext get-forward-sexp posstart)]) 221 | (cond 222 | [posend 223 | (sexp-st posstart posend (send mytext get-text posstart posend))] 224 | [else #f]))] 225 | [else #f]))) 226 | (define (get-right-exp) 227 | (let* ([posnow (send mytext get-start-position)] 228 | [posend (send mytext get-forward-sexp posnow)]) 229 | (cond [posend 230 | (let ([posstart (send mytext get-backward-sexp posend)]) 231 | (cond 232 | [posstart 233 | (sexp-st posstart posend (send mytext get-text posstart posend))] 234 | [else 235 | #f]))] 236 | [else #f]))) 237 | 238 | 239 | (define (get-left-exp) 240 | (let* ([posnow (send mytext get-start-position)] 241 | [posstart (send mytext get-backward-sexp posnow)]) 242 | (cond [posstart 243 | (let ([posend (send mytext get-forward-sexp posstart)]) 244 | (cond 245 | [posend 246 | (sexp-st posstart posend (send mytext get-text posstart posend))] 247 | [else 248 | #f]))] 249 | [else #f]))) 250 | (define adjust-num 251 | (let ([mydialog 'null] 252 | [myslider 'null] 253 | [num 0] 254 | [startpos 0] 255 | [granularity 0];粒度 256 | [endpos 0]) 257 | (lambda (s e n) 258 | (begin 259 | (define cb 260 | (lambda (b e) 261 | (let* ([s-v (/ (send b get-value) 10.0)] 262 | [newnum (+ num (* granularity (* s-v s-v s-v)))] 263 | [newstr (number->string newnum)] 264 | [strlen (string-length newstr)]) 265 | (begin 266 | (send mytext insert newstr startpos endpos) 267 | (set! endpos (+ startpos strlen)))))) 268 | (set! num n) 269 | (cond 270 | [(= 0 n) 271 | (set! granularity 0.1)] 272 | [else (set! granularity (exact->inexact (abs (/ n 100))))]) 273 | (set! startpos s) 274 | (set! endpos e) 275 | (set! mydialog (new dialog% [label "adjust num"])) 276 | (set! myslider (new slider% [label "d"] 277 | [min-value -100] 278 | [max-value 100] 279 | [style (list 'plain 'horizontal)] 280 | [init-value 0] 281 | [callback cb] 282 | [parent mydialog])) 283 | (send mydialog show #t))))) 284 | (define (detect-adjust-color amt) 285 | #f) 286 | (define (detect-adjust-num amt) 287 | (let ([num (string->number (sexp-st-sexp amt))]) 288 | (cond [num 289 | (adjust-num (sexp-st-start amt) (sexp-st-end amt) num)] 290 | [else #f]))) 291 | (define (do-adjust) 292 | (let ([done #f]) 293 | (begin 294 | (cond [(not done) 295 | (let ([nowsexp (get-out-exp)]) 296 | (cond [nowsexp 297 | (set! done (or (detect-adjust-color nowsexp) (detect-adjust-num nowsexp)))]))]) 298 | (cond [(not done) 299 | (let ([nowsexp (get-left-exp)]) 300 | (cond [nowsexp 301 | (set! done (or (detect-adjust-color nowsexp) (detect-adjust-num nowsexp)))]))]) 302 | (cond [(not done) 303 | (let ([nowsexp (get-right-exp)]) 304 | (cond [nowsexp 305 | (set! done (or (detect-adjust-color nowsexp) (detect-adjust-num nowsexp)))]))])))) 306 | 307 | (define mytext (new my-text%)) 308 | (define outputtext (new racket:text%)) 309 | 310 | (define (outputsuccess) 311 | (begin 312 | (send outputtext erase) 313 | (send outputtext insert "success\n" 0))) 314 | (define (outputerror amt) 315 | (begin 316 | (send outputtext erase) 317 | 318 | (send outputtext insert "#error:\n" 0) 319 | (define outputs (open-output-string)) 320 | (display amt outputs) 321 | (send outputtext insert (get-output-string outputs) (send outputtext last-position )) 322 | (cond 323 | [(send outputtext get-dc) 324 | (begin 325 | ; (printf "find dc") 326 | (send (send outputtext get-dc) set-background (make-object color% 0 255 0)))]))) 327 | 328 | 329 | 330 | 331 | (define mb (new menu-bar% [parent myframe])) 332 | (define m-edit (new menu% [label "Edit"] [parent mb])) 333 | (define m-font (new menu% [label "Font"] [parent mb])) 334 | (append-editor-operation-menu-items m-edit #f) 335 | (append-editor-font-menu-items m-font) 336 | ;(define-namespace-anchor nsanchor) 337 | ;(define nsid (namespace-anchor->namespace nsanchor)) 338 | ;(namespace-require 'racket) 339 | (define (test mystring) 340 | (define code-p (open-input-string mystring)) 341 | (define code (read-syntax " " code-p)) 342 | (eval code)) 343 | 344 | 345 | (define maintimer 346 | (new timer% 347 | [interval timeinteval] 348 | [notify-callback 349 | (lambda () 350 | (with-handlers ([exn:fail? (lambda (exn) (void)) ]) 351 | ;(display "kk") 352 | 353 | (begin 354 | (cond [(not initcomplete) 355 | (begin 356 | (send mytext on-change) 357 | (set! editor-change #f) 358 | (set! initcomplete #t))]) 359 | (define currentstate (mainloop (get-interval) eventlist (send statequeue getdata (- statelen 1)))) 360 | 361 | (send eventqueue insert eventlist) 362 | (send statequeue insert (mycopystate currentstate)) 363 | (set! eventlist '()) 364 | (set! nowstate currentstate) 365 | (send game-canvas on-paint) 366 | ;(showoncanvas currentstate) 367 | 368 | ) 369 | ))])) 370 | 371 | 372 | (super-new) ; superclass initialization 373 | (define/public recalculate 374 | (lambda () 375 | (let ([ref (send myslider get-value)]) 376 | (cond [(< ref (- statelen 1)) 377 | (let ([n (send statequeue backto ref)] 378 | 379 | [ms (send statequeue getdata ref)]) 380 | (begin 381 | (for ([i (in-range ref (+ ref n))]) 382 | (let* ([e (send eventqueue getdata (+ i 1))]) 383 | (begin 384 | (with-handlers ([exn:fail? (lambda (exn) (send statequeue insertwitholddata))]) 385 | (set! ms (mainloop timeinteval e (mycopystate ms) )) 386 | (send statequeue insert ms)))) 387 | ) 388 | (slider-cb myslider 'slider)) 389 | )])))) 390 | (define/public (run) 391 | (begin 392 | (send editor-canvas set-editor mytext) 393 | (send output-canvas set-editor outputtext) 394 | (send (send output-canvas get-dc) set-font (make-object font% 150 'default)) 395 | (send myframe show #t) 396 | (send mytext load-file mainfstring 'text) 397 | )) 398 | )) 399 | --------------------------------------------------------------------------------