VIPER Paradice/VIPER.ISO/pc/SCRIPTS/SYSTEM.VSC

Text File | 2002-06-28 | 11.9 KB | 444 lines

;;
;; system.vsc
;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; commentì\ò╢
(define-syntax comment
  (syntax-rules ()
                ((comment body ...)
                 #f))
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; whileì\ò╢
(define-syntax while
  (syntax-rules ()
                ((while cond body ...)
                 ((lambda (x)
                    (call/cc (lambda (y) (set! x y)))
                    (if cond
                        (begin
                          body
                          (x #t))))
                  #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; random
(define (random max)
  (vism:random max)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; currentâpâëâüü[â^âAâNâZâT
(define (current-player session)
  (session-order-get session
                     (session-currentplayerindex-get session))
  )

(define (current-character player)
  (player-characters-get player 0)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; óÄ⌐ò¬ê╚èOé╠âvâîü[âäü[üv
(define (other-players session)
  (let* ((count        (session-order-length session))
         (current    (session-currentplayerindex-get session))
         (others    '()))
    (do ((i 0 (+ 1 i)))
        ((<= count i) #f)
      (if (and
           ;; Ä⌐ò¬é┼é╚é¡
           (not (= i current))
           ;; âSü[âïì╧é▌é┼é╚é»éΩé╬
           (=
            (character-ranking-get
             (player-characters-get (session-order-get session i) 0))
            -1))
          (set! others (cons (session-order-get session i) others))))
    others
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; óÄ⌐ò¬ê╚èOé╠âvâîü[âäü[é╠éñé┐êΩÉlüv
(define (another-player session)
  (let* ((others    (other-players session))
         (count        (length others)))
    (list-ref others (random count))
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; âÇü[ârü[é╠âèâXâg
(define (movie-list character)
  (let* ((movies    '())
         (movie        #f))
    (do ((i 0 (+ 1 i)))
        ((<= 25 i) #f)
      (set! movie
            (movie-silver-get (character-moviecards-get character i)))
      (while (< 0 movie)
             (set! movies (cons i movies))
             (set! movie (- movie 1)))
      )
    movies
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; âÇü[ârü[é≡û│ì∞ê╫é╔1ûçê┌É╨
(define (move-movie dst-character src-character)
  (let* ((movies (movie-list src-character)))
    (if (pair? movies)
        (let* ((index    (list-ref movies (random (length movies))))
               (movie    #f))
          ;; src
          (set! movie (character-moviecards-get src-character index))
          (movie-silver-apply movie (lambda (x) (- x 1)))
          ;; dst
          (set! movie (character-moviecards-get dst-character index))
          (movie-silver-apply movie (lambda (x) (+ x 1)))
          index
          )
        #f)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ü¢ü¢âJü[âhé═Ä¥é┴é─éΘüH
(define (has-card? session character card-name)
  (let* ((n (character-spellcards-length character))
         (card            #f)
         (spell-index    #f)
         (spell            #f)
         (r                '()))
    (do ((i 0 (+ 1 i)))
        ((>= i n) #f)
      (set! card        (character-spellcards-get character i))
      (set! spell-index (card-spell-get card))
      (set! spell (session-spellpool-get session spell-index))
      (if (string=? (spell-name-get spell) card-name)
          (set! r (cons card r)))
      )
    (if (null? r) #f r)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ä╠é─éτéΩéΘâJü[âhé═Ä¥é┴é─éΘüH
(define (has-discardable? session character)
  (let* ((n (character-spellcards-length character))
         (card            #f)
         (spell            #f)
         (r                #f))
    (do ((i 0 (+ 1 i)))
        ((>= i n) #f)
      (set! card        (character-spellcards-get character i))
      (set! spell        (call-pull-spell card))
      (if (spell-candiscard-get spell)
          (set! r #t))
      )
    r
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; âWâââôâv
(define (jump-aux session)
  (let* ((player    (current-player session))
         (character (current-character player))
         (step        (+ 2 (random 4)))
         (location    (character-location-get character)))
    (while
     (and
      ;; stepé¬0é┼é╚é¡
      (not (= step 0))

      ;; êΩû{ô╣é┼
      (= 1 (node-links-length location))

      (or
       ;; âWâââôâvèJÄnÆnô_é┼éáéΘé⌐
       (eqv? (character-location-get character) location)
       (and
        ;; ï¡ÉºÆΓÄ~é┼é╚éó
        (not (node-forcebreak-get location))

        ;; "âWâââôâv"é┼éαé╚éó
        ;;(not (string=? (node-flowstop-get location) "âWâââôâv"))
        )))
     (set! step (- step 1))
     (set! location (node-links-get location 0)))

    (if (not (eqv? (character-location-get character) location))
        (begin
          (call-play-se =jump= #f)
          (call-react character "jump1")
          (call-jump character location)
          (call-react character "jump3")
          (character-jumpcount-apply character (lambda (x) (+ x 1)))))
    (character-walk-set character 0)


    ;; û▀éΦÆlüiæ╜ÆiâWâââôâvë┬ö\é⌐é╟éñé⌐üj
    (and
     ;; êΩû{ô╣é┼
     (= 1 (node-links-length location))
     ;; ï¡ÉºÆΓÄ~é┼é╚éó
     (not (node-forcebreak-get location))
     )
    )
  )

(define (jump session times)
  (let* ((player    (current-player session))
         (character (current-character player))
         (next-jump #t))
    (while
     (and (< 0 times) next-jump)
     (set! next-jump (jump-aux session))
     (set! times (- times 1))
     )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; âVü[âNâîâbâgâJü[âhé╠Ä»ò╩
(define (identify-secret-cards session)
  (let* ((player    (current-player session))
         (character (current-character player))
         (cards        (has-card? session character "âVü[âNâîâbâgâÇü[ârü[")))
    (for-each
     (lambda (card)
       (call-show-spell-card card)
       (call-prompt
        "<p>Eine Secrert Card fur dich!<br/>"
        "Was fur eine wuerde es sein....?</p>")
       (call-hide-spell-card)
       (call-remove-spell-card card)
       (let* ((movie    (call-generate-movie-card #t)))
         (if (pair? movie)
             ;; silver
             (begin
               (call-show-movie-card (car movie) (cdr movie))
               (call-prompt "<p>Es ist eine Silver Card!</p>")
               (call-increment-bingo-item character (car movie) (cdr movie))
               )
             ;; gold
             (begin
               (call-show-movie-card movie -1)
               (call-prompt
                "<p>Wow, es ist eine Golden Card! Du hast eine ganze Reihe vollendet!</p>")
               (for-each
                (lambda (silver)
                  (call-increment-bingo-item character movie silver))
                '(0 1 2 3 4))
               )
             )
         )
       )
     cards)
    (call-hide-movie-card)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nodeé╠ö¡î⌐
(define (find-node session node-name)
  (let* ((n        (session-nodepool-length session))
         (node    #f)
         (r        #f))
    (do ((i 0 (+ 1 i)))
        ((>= i n) #f)
      (set! node        (session-nodepool-get session i))
      (if (string=? (node-name-get node) node-name)
          (set! r node))
      )
    r)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 1Äⁿâ{ü[âiâX
(define (adjust-bonus bonus lap)
  (/ (* bonus (+ 10 (* 2 (- lap 1)))) 10)
  )

(define (earn-lap-bonus session character)
  (let* ((lap        (character-lap-get character))
         (cards        (has-card? session character "âVü[âNâîâbâg"))
         (currency    (session-currencyunit-get session))
         (silvers    #f)
         (panics    #f)
         (bingos    #f)
         (mysteries    #f)
         )
    (call-play-se =goal= #f)
    (call-wait-a-moment 120)

    ;; èeâJü[âhé╠ûçÉöé╠âJâEâôâg
    (set! silvers    (call-count-silver-cards    character))
    (set! panics    (call-count-panic-cards        character))
    (set! bingos    (call-count-bingo-lines        character))
    (set! mysteries    (call-count-mystery-cards    character))

    ;; Åçê╩â{ü[âiâX
    (let* ((rank    (call-get-rank character #t))
           (earn (adjust-bonus
                  (case rank
                    ((0) 100000)
                    ((1) 50000)
                    ((2) 20000)
                    ((3) 10000))
                  lap)))
      (if (< 0 earn)
          (begin
            (call-prompt "<p>"
                         (number->string (+ 1 rank))
                         "Du bist jetzt drann...<br/>"
                         (number->string earn)
                         currency
                         " bonus!</p>")
            (character-money-apply character (lambda (x) (+ x earn)))
            (call-show-income earn)
            ))
      )

    ;; â~âXâeâèü[â{ü[âiâX ûçÉöü~20000ë~
    (if (< 0 mysteries)
        (let* ((earn (adjust-bonus (* 20000 mysteries) lap)))
          (call-prompt "<p>Du besitztst "
                       (number->string mysteries)
                       " eine Mistery Card, also<br/>"
                       (number->string earn)
                       currency
                       " bonus</p>")
          (character-money-apply character (lambda (x) (+ x earn)))
          (call-show-income earn)
          )
        )

    ;; âpâjâbâNâÇü[ârü[âJü[âhæ╡é┴é─éΘâ{ü[âiâX4û£ë~
    (if (< 0 (call-check-bingo-row character 2))
        (let* ((earn (* 40000 (call-check-bingo-row character 2))))
          (call-prompt "<p>Du hast die Panic Movie gesammelt, also<br/>"
                       (number->string earn)
                       currency
                       " bonus!</p>")
          (character-money-apply character (lambda (x) (+ x earn)))
          (call-show-income earn)
          )
        )

    ;; ïΓâÇü[ârü[â{ü[âiâX ûçÉöü~5000ë~
    (if (< 0 silvers)
        (let* ((earn (* 5000 silvers)))
          (call-prompt "<p>Du besitzst"
                       (number->string silvers)
                       " die Silever Movie, also<br/>"
                       (number->string earn)
                       currency
                       " bonus!</p>")
          (character-money-apply character (lambda (x) (+ x earn)))
          (call-show-income earn)
          )
        )

    ;; ârâôâSâ{ü[âiâX lineÉöü~25000ë~
    (if (< 0 bingos)
        (let* ((earn (* 25000 bingos)))
          (call-prompt "<p>Du hast sogar das "
                       (number->string bingos)
                       " Bingo Panel gesammelt, also bekommst du auch  hiermit der<br/>"
                       (number->string earn)
                       currency
                       " bonus!</p>")
          (character-money-apply character (lambda (x) (+ x earn)))
          (call-show-income earn)
          )
        )

;    ;; âpü[âtâFâNâgârâôâSâ{ü[âiâX 500000
;    (if (< 0 (call-check-bingo-perfect character))
;        (let* ((earn 500000))
;          (call-prompt "<p>Du hast  Bingo gemacht. Das bedeutet: 50.000"
;                       currency
;                       " bonus!</p>")
;          (character-money-apply character (lambda (x) (+ x earn)))
;          (call-show-income earn)
;          )
;        )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; get-salary
(define (get-salary character min max)
  (* (+ 1 (character-lap-get character))
     (+ (* (random (/ (- max min -1) 100)) 100) min))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; get-bonus
(define (get-bonus lap)
   (let* ((n 0))
     (while (<= 0 lap)
            (set! n (+ n (* (+ 5 (random 6)) 10000)))
            (set! lap (- lap 1))
            )
     n
     )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exchange-movie
(define (exchange-movie gold silver left right)
  (let* ((index        (+ (* 5 gold) silver))
         (lmovie    0)
         (rmovie    0))
    (set! lmovie (movie-silver-get (character-moviecards-get left index)))
    (set! rmovie (movie-silver-get (character-moviecards-get right index)))
    (movie-silver-set (character-moviecards-get left index) rmovie)
    (movie-silver-set (character-moviecards-get right index) lmovie)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exchange-backslash
(define (exchange-backslash left right)
  (exchange-movie 0 0 left right)
  (exchange-movie 1 1 left right)
  (exchange-movie 2 2 left right)
  (exchange-movie 3 3 left right)
  (exchange-movie 4 4 left right)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exchange-slash
(define (exchange-slash left right)
  (exchange-movie 0 4 left right)
  (exchange-movie 1 3 left right)
  (exchange-movie 2 2 left right)
  (exchange-movie 3 1 left right)
  (exchange-movie 4 0 left right)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exchange-row
(define (exchange-row row left right)
  (exchange-movie row 0 left right)
  (exchange-movie row 1 left right)
  (exchange-movie row 2 left right)
  (exchange-movie row 3 left right)
  (exchange-movie row 4 left right)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exchange-col
(define (exchange-col col left right)
  (exchange-movie 0 col left right)
  (exchange-movie 1 col left right)
  (exchange-movie 2 col left right)
  (exchange-movie 3 col left right)
  (exchange-movie 4 col left right)
  )