gistfile1.txt

gosh> (load "./twitterland-examples")
(-< yamasushi <@yamasushi : "まじです"> [@yamasushi : <@yamasushi : "つぶやき,はじめます">])
(-< null <@shuji : "まじで?"> [@null : <@yamasushi : "つぶやき,はじめます">])
(-< null <@yamasushi : "つぶやき,はじめます"> [@null : #f])
(-< shuji <@shuji : "まじで?"> [@shuji : #f])
(-< yamasushi <@yamasushi : "つぶやき,はじめます"> [@yamasushi : #f])
(-< null <@yamasushi : "まじです"> [@null : <@shuji : "まじで?">])
(-> shuji <@yamasushi : "まじです"> [@shuji : <@shuji : "まじで?">])
(-> yamasushi <@shuji : "まじで?"> [@yamasushi : <@yamasushi : "つぶやき,はじめます">])


#t

twitterland-examples.scm

(use graph)
(use graph.twitterland)

; GIST :
; https://gist.github.com/yamasushi/0694d47788d927e1a971

(define null      (make-tweeter 'null ))
(define yamasushi (make-tweeter 'yamasushi))
(define shuji     (make-tweeter 'shuji))

(tweet! yamasushi "つぶやき,はじめます")
(retweet! null yamasushi)
(mention! shuji yamasushi "まじで?")
(retweet! null shuji)
(mention! yamasushi shuji "まじです")
(retweet! null yamasushi)

(graph-for-each print (twitterland) )

(print "\n")

twitterland.scm

;; twitterland graph
(define-module graph.twitterland
  (use graph)
  (use gauche.parameter)
  (export
      twitterland
      <tweet> <context> <tweeter> <archive>
      for-each fold push
      tweet! retweet! mention! now archive
      make-tweeter make-tweet) )
(select-module graph.twitterland)

; GIST :
; https://gist.github.com/yamasushi/0694d47788d927e1a971

(define twitterland (make-parameter (make-graph)) )

(define-class <tweet> []
  [(id       :init-keyword :id)
   (content  :init-keyword :content )
   (reply-to :init-keyword :reply-to :init-value '() )
   (reply    :init-keyword :reply    :init-value '() )] )

(define-method object-hash ((t <tweet>))
  ($ hash $ list (~ t 'id) (~ t 'content) ) )

;; <tweet>の表示
;; ?? reply-to,replyをいかに表示するか ??
(define-method write-object ((t <tweet>) port)
  (format port "<@~s : ~s>" (~ t 'id) (~ t 'content) ))

(define-class <context> []
  [(id     :init-keyword :id)
   (tweets :init-keyword :tweets :init-value '() ) ] )

(define-method object-hash ((c <context>))
  ($ hash $ list (~ c 'id) (~ c 'tweets) ) )

;; <context>の表示
(define-method write-object ((c <context>) port)
  (format port "[@~s : ~s]" (~ c 'id) (now c) ))

(define-method now ((c <context>))
  (let1 ts (~ c 'tweets)
    (if (null? ts)
        #f
        (car ts) ) ) )

(define-method push((c <context>) (t <tweet>))
  (make <context>
    :id (~ c 'id)
    :tweets (cons t (~ c 'tweets) ) ) )

(define-method for-each(proc (c <context>))
    (for-each proc (~ c 'tweets) ) )

(define-method fold (kons knil (c <context>))
    (fold kons knil (~ c 'tweets)) )

; tweeter
(define-class <tweeter> []
  [(id      :init-keyword :id)
   (context :init-keyword :context ) ] )

(define-class <archive> []
  [(id      :init-keyword :id)
   (context :init-keyword :context)] )

;; <tweeter>の表示
(define-method write-object ((t-er <tweeter>) port)
  (format port "{{@~s : ~s}}" (~ t-er 'id) (now t-er) ))

;; <archive>の表示
(define-method write-object ((t-er <archive>) port)
  (format port "{@~s : ~s}" (~ t-er 'id) (now t-er) ))

(define-method make-tweeter ((id <symbol>))
  (make <tweeter> :id id :context (make <context> :id id ) ) )

(define-method make-tweet   ((t-er <tweeter>) content)
  (make <tweet>
    :id (~ t-er 'id)
    :content content ) )

(define-method now ((t <tweeter>)) (now (~ t 'context)))
(define-method now ((a <archive>)) (now (~ a 'context)))

(define-method archive ((t <tweeter>))
  (make <archive>
        :id      (~ t 'id)
        :context (~ t 'context) ) )

(define-method %tweet! ( (t-er <tweeter>) (t <tweet>) )
  ; update twitterland
  (twitterland
    (graph-adjoin (twitterland) (-< (~ t-er 'id) t (~ t-er 'context) ) ) )
  ; update tweeter
  (set! (~ t-er 'context) (push (~ t-er 'context) t) )
  #t
)

(define-method tweet! ( (t-er <tweeter>) content )
  (%tweet! t-er (make-tweet t-er content) ) )

(define-method retweet! ( (rt-er <tweeter>) (to <tweeter>))
  (if (now to)
    (%tweet! rt-er (now to) )
    #f ) )

(define-method %mention! ( (t-er <tweeter>) to content)
  (let [(now-to (now to) )
        (t  (make-tweet t-er content))]
    (if now-to
      (begin
        ;; set reply-to of replyer
        (set! (~ t 'reply-to)
          (cons now-to (~ now-to 'reply-to ) )
          )
        ;; set reply of replyee
        (set! (~ now-to 'reply)
          (cons t (~ now-to 'reply) ) )
        ) )
    (%tweet! t-er t)
    ; update twitterland
    (twitterland
      (graph-adjoin
        (twitterland)
        (-> (~ to 'id) t (~ to 'context) ))
      ) ) )

(define-method mention! ( (t-er <tweeter>) (to <tweeter>) content)
  (%mention! t-er to content) )

(define-method mention! ( (t-er <tweeter>) (to <archive>) content)
  (%mention! t-er to content) )