API tools faq
paste
Advertisement
Guest User

Paint

a guest
Oct 16th, 2018
246
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Racket 15.71 KB | None | 0 0
raw download clone embed print report
  1. #lang racket
  2. (require 2htdp/image)
  3. (require 2htdp/universe)
  4. ((lambda (x)
  5.    (local ((define (I-th s i)
  6.              (local ((define (for_I-th s i k)
  7.                        (cond
  8.                          ((= k i) (car s))
  9.                          (else (for_I-th (cdr s) i (add1 k))))))
  10.                (cond
  11.                  ((and (positive? i) (integer? i) (<= i (length s))) (for_I-th s i 1))
  12.                  (else '()))))
  13.            (define (eqc? a b)
  14.              (if (and (= (color-red a) (color-red b)) (= (color-green a) (color-green b)) (= (color-blue a) (color-blue b)) (= (color-alpha a) (color-alpha b)))
  15.                  #t
  16.                  #f))
  17.            (define-struct coord (x y))
  18.            (define (Exists? f)
  19.              (if (file-exists? f)
  20.                  (if (or (> (image-width (bitmap/file f)) 1300) (> (image-height (bitmap/file f)) 650))
  21.                      (empty-scene 1300 650)
  22.                      (bitmap/file f))
  23.                  (empty-scene 1300 675)))
  24.            (define (-> x)
  25.              (overlay/align "left" "top"
  26.                             (beside
  27.                              (overlay
  28.                               (text "Открыть" 16 "black")
  29.                               (rectangle 100 25 "outline" "black"))
  30.                              (overlay
  31.                               (text "Сохранить" 16 "black")
  32.                               (rectangle 100 25 "outline" "black"))
  33.                              (overlay
  34.                               (beside (overlay
  35.                                        (text "-" 16 "black")
  36.                                        (square 25 "outline" "black"))
  37.                                       (overlay
  38.                                        (text (number->string (car (cdr (cdr (cdr x))))) 16 "black")
  39.                                        (rectangle 50 25 "outline" "black"))
  40.                                       (overlay
  41.                                        (text "+" 16 "black")
  42.                                        (square 25 "outline" "black")))
  43.                               (rectangle 100 25 "outline" "black"))
  44.                              (overlay
  45.                               (text "Сменить стиль" 12 "black")
  46.                               (rectangle 100 25 "outline" "black"))
  47.                              (overlay
  48.                               (beside (rectangle 10 25 "solid" "red")
  49.                                       (rectangle 10 25 "solid" "orange")
  50.                                       (rectangle 10 25 "solid" "yellow")
  51.                                       (rectangle 10 25 "solid" "darkseagreen")
  52.                                       (rectangle 10 25 "solid" "lightblue")
  53.                                       (rectangle 10 25 "solid" "blue")
  54.                                       (rectangle 10 25 "solid" "purple")
  55.                                       (rectangle 10 25 "solid" "white")
  56.                                       (rectangle 10 25 "solid" "pink")
  57.                                       (rectangle 10 25 "solid" "black"))
  58.                               (rectangle 100 25 "outline" "black"))
  59.                              (overlay
  60.                               (square 25 "outline" "black")
  61.                               (bitmap/file "curve.jpg"))
  62.                              (overlay
  63.                               (square 25 "outline" "black")
  64.                               (bitmap/file "line.jpg"))
  65.                              (overlay
  66.                               (square 25 "outline" "black")
  67.                               (bitmap/file "rec.png"))
  68.                              (overlay
  69.                               (square 25 "outline" "black")
  70.                               (bitmap/file "fill.png"))
  71.                              (rectangle 699 25 "outline" "black"))
  72.                             (car x)))
  73.            (define (D x f)
  74.              (cond
  75.                ((= (length x) 4) (cons (f (car x)) (cdr x)))
  76.                (else (cons (car x) (D (cdr x) f)))))
  77.            (define (Figure x)
  78.              (if (zero? (car (cdr (reverse x))))
  79.                  (circle (* (car (cdr (cdr (cdr x)))) 0.5) "solid" (car (cdr (cdr (cdr (cdr x))))))
  80.                  (square (car (cdr (cdr (cdr x)))) "solid" (car (cdr (cdr (cdr (cdr x))))))))
  81.            (define (->Figure x)
  82.              (if (zero? x)
  83.                  1
  84.                  0))
  85.            (define (Colour n)
  86.              (cond
  87.                ((= n 0) "red")
  88.                ((= n 1) "orange")
  89.                ((= n 2) "yellow")
  90.                ((= n 3) "darkseagreen")
  91.                ((= n 4) "lightblue")
  92.                ((= n 5) "blue")
  93.                ((= n 6) "purple")
  94.                ((= n 7) "white")
  95.                ((= n 8) "pink")
  96.                (else "black")))
  97.            (define (->Colour x n)
  98.              (cond
  99.                ((string? (car x)) (cons (Colour n) (cdr x)))
  100.                (else (cons (car x) (->Colour (cdr x) n)))))
  101.            (define (?Form x)
  102.              (if (zero? x)
  103.                  "round"
  104.                  "projecting"))
  105.            (define (??Form x)
  106.              (if (zero? x)
  107.                  "round"
  108.                  "bevel"))
  109.            (define ($Dr x)
  110.              (if (zero? (car (reverse x)))
  111.                  (overlay
  112.                   (text "Заставка" 16 "black")
  113.                   (empty-scene 1300 675))
  114.                  (-> x)))
  115.            (define (c->st c)
  116.              (car (image->color-list (square 1 "solid" c))))
  117.            (define (OldCCoord x old_c s n)
  118.              (cond
  119.                ((empty? x) s)
  120.                ((eqc? (car x) old_c) (OldCCoord (cdr x) old_c (cons n s) (add1 n)))
  121.                (else (OldCCoord (cdr x) old_c s (add1 n)))))
  122.            (define (FoundR s n)
  123.              (cond
  124.                ((<= (* n 1300) s (* (add1 n) 1300)) (make-coord (- s (* n 1300)) (add1 n)))
  125.                (else (FoundR s (add1 n)))))
  126.            (define (ReallyOCC s)
  127.              (cond
  128.                ((empty? s) '())
  129.                (else (cons (FoundR (car s) 0) (ReallyOCC (cdr s))))))
  130.            (define (h?* s for_h)
  131.              (cond
  132.                ((empty? for_h) #f)
  133.                ((h? s (car for_h)) #t)
  134.                (else (h?* s (cdr for_h)))))
  135.            (define (h? s c)
  136.              (cond
  137.                ((empty? s) #f)
  138.                ((and (<= 0 (abs (- (coord-x (car s)) (coord-x c))) 1) (<= 0 (abs (- (coord-y (car s)) (coord-y c))) 1)) #t)
  139.                (else (h? (cdr s) c))))
  140.            (define (d* s for_h)
  141.              (cond
  142.                ((empty? s) '())
  143.                ((and (<= 0 (abs (- (coord-x (car s)) (coord-x for_h))) 1) (<= 0 (abs (- (coord-y (car s)) (coord-y for_h))) 1)) (d* (cdr s) for_h))
  144.                (else (cons (car s) (d* (cdr s) for_h)))))
  145.            (define (g new_s s for_h)
  146.              (cond
  147.                ((empty? s) new_s)
  148.                ((and (<= 0 (abs (- (coord-x (car s)) (coord-x for_h))) 1) (<= 0 (abs (- (coord-y (car s)) (coord-y for_h))) 1)) (g (cons (car s) new_s) (cdr s) for_h))
  149.                (else (g new_s (cdr s) for_h))))
  150.            (define (Select** s for_h for_h* new_s)
  151.              (cond
  152.                ((empty? for_h) (Select* s for_h* new_s))
  153.                (else (Select** (d* s (car for_h)) (cdr for_h) (g for_h* s (car for_h)) (g new_s s (car for_h))))))
  154.            (define (Select* s for_h new_s)
  155.              (cond
  156.                ((h?* s for_h) (Select** s for_h '() new_s))
  157.                (else new_s)))
  158.            (define (eqcc? s1 s2)
  159.              (if (and (= (coord-x s1) (coord-x s2)) (= (coord-y s1) (coord-y s2)))
  160.                  #t
  161.                  #f))
  162.            (define (d s el)
  163.              (cond
  164.                ((empty? s) '())
  165.                ((eqcc? (car s) el) (d (cdr s) el))
  166.                (else (cons (car s) (d (cdr s) el)))))
  167.            (define (Del s)
  168.              (cond
  169.                ((empty? s) '())
  170.                (else (cons (car s) (Del (d (cdr s) (car s)))))))
  171.            (define (~>* s)
  172.              (cond
  173.                ((empty? s) '())
  174.                (else (cons (+ (* (sub1 (coord-y (car s))) 1300) (coord-x (car s))) (~>* (cdr s))))))
  175.            (define (Sorted? s)
  176.             (cond
  177.               ((empty? s) #t)
  178.               ((empty? (cdr s)) #t)
  179.               ((<= (car s) (car (cdr s))) (Sorted? (cdr s)))
  180.               (else #f)))
  181.            (define (Cut s i)
  182.              (local ((define (SubCut s i k)
  183.                        (cond
  184.                          ((= k i) '())
  185.                          (else (cons (car s) (SubCut (cdr s) i (add1 k)))))))
  186.                (SubCut s i 0)))
  187.            (define (UnCut s i)
  188.              (local ((define (SubUnCut s i k)
  189.                        (cond
  190.                          ((= k i) s)
  191.                          (else (SubUnCut (cdr s) i (add1 k))))))
  192.                (SubUnCut s i 0)))
  193.            (define (Sort_6 s)
  194.              (local ((define (ForOdd s)
  195.                        (add1 (* (sub1 (length s)) 0.5)))
  196.                      (define (ForEven s)
  197.                        (* (length s) 0.5))
  198.                      (define (\ s)
  199.                        (if (odd? (length s))
  200.                            (ForOdd s)
  201.                            (ForEven s)))
  202.                      (define (<<< s1 x)
  203.                        (cond
  204.                          ((empty? s1) '())
  205.                          ((>= (car s1) x) (<<< (cdr s1) x))
  206.                          (else (cons (car s1) (<<< (cdr s1) x)))))
  207.                      (define (>>>= s2 x)
  208.                        (cond
  209.                          ((empty? s2) '())
  210.                          ((< (car s2) x) (>>>= (cdr s2) x))
  211.                          (else (cons (car s2) (>>>= (cdr s2) x)))))
  212.                      (define (<< s1 x s2)
  213.                        (append (<<< s1 x) (<<< s2 x)))
  214.                      (define (>>= s1 x s2)
  215.                        (append (>>>= s2 x) (>>>= s1 x)))
  216.                      (define (** s1 x s2)
  217.                        (append (Sort_6 (<< s1 x s2)) (list x) (Sort_6 (>>= s1 x s2)))))
  218.                (cond
  219.                  ((or (empty? s) (= (length s) 1)) s)
  220.                  (else (** (Cut s (sub1 (\ s))) (I-th s (\ s)) (reverse (UnCut s (\ s))))))))
  221.            (define (~> x i c s)
  222.              (cond
  223.                ((empty? x) '())
  224.                ((empty? s) x)
  225.                ((= i (car s)) (cons c (~> (cdr x) (add1 i) c (cdr s))))
  226.                (else (cons (car x) (~> (cdr x) (add1 i) c s)))))
  227.            (define (f x c Mx My old_c)
  228.              (color-list->bitmap (~> x 1 c (Sort_6 (~>* (Del (Select* (ReallyOCC (OldCCoord x old_c '() 1)) `(,(make-coord Mx My)) `(,(make-coord Mx My))))))) 1300 675))
  229.            (define (** i)
  230.              (local ((define (*** i n x)
  231.                        (cond
  232.                          ((= n x) (color-list->bitmap i 1300 650))
  233.                          (else (*** (cdr i) (add1 n) x)))))
  234.                (*** i 0 (* 1300 25))))
  235.            (define ($M x Mx My B)
  236.              (cond
  237.                ((and (zero? (car (reverse x))) (mouse=? B "button-down")) (reverse (cons 1 (cdr (reverse x)))))
  238.                ((zero? (car (reverse x))) x)
  239.                ((and (<= 0 Mx 100) (<= 0 My 25) (mouse=? B "button-down")) (cons (above (rectangle 1300 25 "solid" "white") (Exists? "img.bmp")) (cons '() (cdr (cdr x)))))
  240.                ((and (<= 100 Mx 200) (<= 0 My 25) (mouse=? B "button-down")) ((lambda (x y) x) x (save-image (** (image->color-list (car x))) "img.bmp")))
  241.                ((and (> (car (cdr (cdr (cdr x)))) 1) (<= 200 Mx 225) (<= 0 My 25) (mouse=? B "button-down")) (D x sub1))
  242.                ((and (< (car (cdr (cdr (cdr x)))) 30) (<= 275 Mx 300) (<= 0 My 25) (mouse=? B "button-down")) (D x add1))
  243.                ((and (<= 300 Mx 400) (<= 0 My 25) (mouse=? B "button-down")) (reverse (cons (car (reverse x)) (cons (->Figure (car (cdr (reverse x)))) (cdr (cdr (reverse x)))))))
  244.                ((and (<= 400 Mx 500) (<= 0 My 25) (mouse=? B "button-down")) (->Colour x (string->number (substring (number->string Mx) 1 2))))
  245.                ((and (<= 500 Mx 525) (<= 0 My 25) (mouse=? B "button-down")) (cons (car x) (cons (car (cdr x)) (cons 0 (cdr (cdr (cdr x)))))))
  246.                ((and (<= 525 Mx 550) (<= 0 My 25) (mouse=? B "button-down")) (cons (car x) (cons (car (cdr x)) (cons 1 (cdr (cdr (cdr x)))))))
  247.                ((and (<= 550 Mx 575) (<= 0 My 25) (mouse=? B "button-down")) (cons (car x) (cons (car (cdr x)) (cons 2 (cdr (cdr (cdr x)))))))
  248.                ((and (<= 575 Mx 600) (<= 0 My 25) (mouse=? B "button-down")) (cons (car x) (cons (car (cdr x)) (cons 3 (cdr (cdr (cdr x)))))))
  249.                ((and (zero? (car (cdr (cdr x)))) (>= My (+ 25 (* (car (cdr (cdr (cdr x)))) 0.5))) (mouse=? B "drag")) (cons (place-image (Figure x) Mx My (car x)) (cons (cons (make-coord Mx My) (car (cdr x))) (cdr (cdr x)))))
  250.                ((and (= (car (cdr (cdr x))) 1) (>= My (+ 25 (* (car (cdr (cdr (cdr x)))) 0.5))) (mouse=? B "button-down") (false? (empty? (car (cdr x)))) (list? (car (car (cdr x)))) (= (length (car (car (cdr x)))) 1))
  251.                 (cons (scene+line (car x)
  252.                                   (coord-x (car (car (car (cdr x))))) (coord-y (car (car (car (cdr x))))) Mx My
  253.                                   (make-pen (car (cdr (cdr (reverse x)))) (car (cdr (cdr (cdr x)))) "solid" (?Form (car (cdr (reverse x)))) (??Form (car (cdr (reverse x))))))
  254.                       (cons (cons (cons (make-coord Mx My) (car (car (cdr x)))) (cdr (car (cdr x)))) (cdr (cdr x)))))
  255.                ((and (= (car (cdr (cdr x))) 1) (>= My (+ 25 (* (car (cdr (cdr (cdr x)))) 0.5))) (mouse=? B "button-down")) (cons (car x) (cons (cons `(,(make-coord Mx My)) (car (cdr x))) (cdr (cdr x)))))
  256.                ((and (= (car (cdr (cdr x))) 2) (>= My (+ 25 (* (car (cdr (cdr (cdr x)))) 0.5))) (mouse=? B "button-down") (false? (empty? (car (cdr x)))) (list? (car (car (cdr x)))) (= (length (car (car (cdr x)))) 1))
  257.                 (cons (scene+line (scene+line (scene+line (scene+line (car x)
  258.                                   (coord-x (car (car (car (cdr x))))) My Mx My
  259.                                   (make-pen (car (cdr (cdr (reverse x)))) (car (cdr (cdr (cdr x)))) "solid" (?Form (car (cdr (reverse x)))) (??Form (car (cdr (reverse x))))))
  260.                                   Mx (coord-y (car (car (car (cdr x))))) Mx My
  261.                                   (make-pen (car (cdr (cdr (reverse x)))) (car (cdr (cdr (cdr x)))) "solid" (?Form (car (cdr (reverse x)))) (??Form (car (cdr (reverse x))))))
  262.                                   (coord-x (car (car (car (cdr x))))) (coord-y (car (car (car (cdr x))))) Mx (coord-y (car (car (car (cdr x)))))
  263.                                   (make-pen (car (cdr (cdr (reverse x)))) (car (cdr (cdr (cdr x)))) "solid" (?Form (car (cdr (reverse x)))) (??Form (car (cdr (reverse x))))))
  264.                                   (coord-x (car (car (car (cdr x))))) (coord-y (car (car (car (cdr x))))) (coord-x (car (car (car (cdr x))))) My
  265.                                   (make-pen (car (cdr (cdr (reverse x)))) (car (cdr (cdr (cdr x)))) "solid" (?Form (car (cdr (reverse x)))) (??Form (car (cdr (reverse x))))))
  266.                       (cons (cons (cons (make-coord Mx My) (car (car (cdr x)))) (cdr (car (cdr x)))) (cdr (cdr x)))))
  267.                ((and (= (car (cdr (cdr x))) 2) (>= My (+ 25 (* (car (cdr (cdr (cdr x)))) 0.5))) (mouse=? B "button-down")) (cons (car x) (cons (cons `(,(make-coord Mx My)) (car (cdr x))) (cdr (cdr x)))))
  268.                ((and (= (car (cdr (cdr x))) 3) (>= My 25) (mouse=? B "button-down"))
  269.                 (cons (f (image->color-list (car x)) (c->st (car (cdr (cdr (reverse x))))) Mx My (I-th (image->color-list (car x)) (+ (* (sub1 My) 1300) Mx))) (cdr x)))
  270.                (else x))))
  271.      (big-bang x
  272.        (to-draw $Dr)
  273.        (on-mouse $M)))) `(,(empty-scene 1300 675) () 0 15 "black" 0 0))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!