fork(1) download
copy 
  1. ;; Define helper functions
  2. (define (drop-while pred lis)
  3.   (if (or (null? lis) (not (pred (car lis))))
  4.       lis
  5.       (drop-while pred (cdr lis))))
  6.  
  7. (define (take-while pred lis)
  8.   (define (take-while-helper pred lis result)
  9.     (if (and (not (null? lis)) (pred (car lis)))
  10.         (take-while-helper pred (cdr lis) (cons (car lis) result))
  11.         (reverse result)))
  12.   (take-while-helper pred lis '()))
  13.  
  14. (define (char-other? ch)
  15.   (not (or (= (char->integer ch) 91)
  16.            (= (char->integer ch) 93)
  17.            (= (char->integer ch) 40)
  18.            (= (char->integer ch) 41)
  19.            (= (char->integer ch) 32)
  20.            (= (char->integer ch) 10))))
  21.  
  22. (define (process-other chars)
  23.   (and (not (null? chars))
  24.        (let* ((token-chars (take-while char-other? chars))
  25.               (rest (drop-while char-other? chars)))
  26.          (list token-chars rest))))
  27.  
  28. ;; Custom function to check if all elements in a list are characters
  29. (define (all-char? lis)
  30.   (if (null? lis)
  31.       #t
  32.       (and (char? (car lis)) (all-char? (cdr lis)))))
  33.  
  34. ;; Function to tag tokens with their type
  35. (define (tag-token type value)
  36.   (list type value))
  37.  
  38. ;; Functions to take and drop elements from the list
  39. (define (take n lis)
  40.   (if (or (<= n 0) (null? lis))
  41.       '()
  42.       (cons (car lis) (take (- n 1) (cdr lis)))))
  43.  
  44. (define (drop n lis)
  45.   (if (or (<= n 0) (null? lis))
  46.       lis
  47.       (drop (- n 1) (cdr lis))))
  48.  
  49. ;; Functions for Dot Count
  50. (define (process-dots chars)
  51.   (let* ((dot-chars (take-while (lambda (ch) (char=? ch (integer->char 46))) chars))  ; char 46 is '.'
  52.          (num-dots (length dot-chars))
  53.          (rest (drop-while (lambda (ch) (char=? ch (integer->char 46))) chars)))
  54.     (list num-dots rest)))
  55.  
  56. ;; Define main tokenize function with integrated new functions
  57. (define (tokenize input)
  58.   (let loop ((chars (string->list input)) (tokens '()))
  59.     (cond
  60.       ((null? chars) (reverse tokens))  ; Return the reversed tokens
  61.       ((char=? (car chars) (integer->char 91))  ; Handle opening bracket [
  62.        (loop (cdr chars) (cons (tag-token 'open-bracket "[") tokens)))
  63.       ((char=? (car chars) (integer->char 93))  ; Handle closing bracket ]
  64.        (loop (cdr chars) (cons (tag-token 'close-bracket "]") tokens)))
  65.       ((char=? (car chars) (integer->char 40))  ; Handle opening parenthesis
  66.        (loop (cdr chars) (cons (tag-token 'open-parenthesis "(") tokens)))
  67.       ((char=? (car chars) (integer->char 41))  ; Handle closing parenthesis
  68.        (loop (cdr chars) (cons (tag-token 'close-parenthesis ")") tokens)))
  69.       ((char=? (car chars) (integer->char 32))  ; Skip spaces
  70.        (loop (cdr chars) tokens))
  71.       ((char=? (car chars) (integer->char 46))  ; Handle dots (.)
  72.        (let* ((result (process-dots chars))
  73.               (num-dots (car result))
  74.               (rest (cadr result)))
  75.          (loop rest (cons (tag-token 'dots num-dots) tokens))))  ; Use a tagged list structure
  76.       (else
  77.        (let* ((result (process-other chars))
  78.               (token (car result))
  79.               (rest (cadr result)))
  80.          (loop rest (cons (tag-token 'other token) tokens))))))  ); End of tokenize function
  81.  
  82. (define (simplify-for-output x) x)
  83.  
  84. ;; Function to check if a token represents dots
  85. (define (dots? x) (and (pair? x) (pair? (car x))
  86.                     (eq? 'dots (caar x))))
  87.  
  88. (define (dot-count x) (cadr x))
  89.  
  90. ;; Function to gather tokens over nested parentheses
  91. (define (gather-tokens tokens)
  92.   (define (helper tokens collected depth)
  93.     (cond
  94.       ((null? tokens) (list (reverse collected) tokens))
  95.       ((and (equal? (car (car tokens)) 'close-parenthesis) (= depth 1))
  96.        (list (reverse (cons (car tokens) collected)) (cdr tokens)))
  97.       ((equal? (car (car tokens)) 'close-parenthesis)
  98.        (helper (cdr tokens) (cons (car tokens) collected) (- depth 1)))
  99.       ((equal? (car (car tokens)) 'open-parenthesis)
  100.        (helper (cdr tokens) (cons (car tokens) collected) (+ depth 1)))
  101.       (else
  102.        (helper (cdr tokens) (cons (car tokens) collected) depth))))
  103.   (helper tokens '() 0))
  104.  
  105. ;; Function to gather and tag tokens based on dots
  106. (define (process-final tokens)
  107.   (define (process-helper reversed-tokens forward-tail)
  108.     (cond
  109.       ((null? reversed-tokens)
  110.        (simplify-for-output forward-tail))
  111.       ((dots? (car reversed-tokens))
  112.        (let* ((count (dot-count (car reversed-tokens)))
  113.               (gathered (gather-tokens forward-tail))
  114.               (the-tail (cons (tag-token 'final (car gathered)) (cdr gathered))))
  115.          (process-helper (cdr reversed-tokens) the-tail)))
  116.       (else
  117.        (process-helper (cdr reversed-tokens) (cons (car reversed-tokens) forward-tail)))))
  118.   (define (process-helperz . args)
  119.     (debug 'process-helper args)
  120.     (apply process-helper args))
  121.   (process-helperz (reverse tokens) '()))
  122.  
  123. ;; DEBUG
  124. (define (debug procedure-name args)
  125.   (define (debug-helper args)
  126.     (if (null? (cdr args))
  127.       args
  128.       (cons (car args)
  129.         (cons '--- (debug-helper (cdr args))))))
  130. (write (cons procedure-name (debug-helper args)))(newline)(newline))
  131.  
  132. ;; Example usage
  133. (define input "(define) f g (). 1 2")
  134.  
  135. ;; Tokenize the input
  136. (let ((tokens (tokenize input)))
  137.   (write tokens)  ; Write the intermediate tokenized output for debugging
  138.   (newline)(newline)
  139.   (write (process-final tokens)))  ; Return the final processed output
  140.  
Success #stdin #stdout 0.01s 8112KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
((open-parenthesis "(") (other (#\d #\e #\f #\i #\n #\e)) (close-parenthesis ")") (other (#\f)) (other (#\g)) (open-parenthesis "(") (close-parenthesis ")") (dots 1) (other (#\1)) (other (#\2)))

(process-helper ((other (#\2)) (other (#\1)) (dots 1) (close-parenthesis ")") (open-parenthesis "(") (other (#\g)) (other (#\f)) (close-parenthesis ")") (other (#\d #\e #\f #\i #\n #\e)) (open-parenthesis "(")) --- ())

((open-parenthesis "(") (other (#\d #\e #\f #\i #\n #\e)) (close-parenthesis ")") (other (#\f)) (other (#\g)) (open-parenthesis "(") (close-parenthesis ")") (dots 1) (other (#\1)) (other (#\2)))
https://ideone.com/o8ImSL
language:
Scheme (chicken 4.13)
created:
7 days ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!