Inner DSL of R to generate MSC

MSC.R

# A R program to help generate MSC charts. 
# The feature to differentiate it from other similar tools is that it support parallel messages. 
# It is in testing phase. 

library("grid")

diagram.params <- list(titleLines=1,
                       headLines=2,
                       widthPad=1,
                       heightPad=0.5,
                       perActionHeight=2, 
                       actionsPad=1,
                       arrowSize=1,
                       rectRadius=1)


diagram.msc <- function(title="unspefied") {
  list(title=title, actions=vector("list"), actors=vector("list"))
}

max.actions.char.number <- function(msc) {
  max(sapply(msc$actions, function(x) {
      max(sapply(x$value, function(y) {
        nchar(y)
      }))
    })) 
}

max.actors.char.number <- function(msc) {
  max(sapply(msc$actors, function(x) nchar(x$longName))) 
}

get.actor.position <- function(msc, shortName){
  which(sapply(msc$actors,function(x) x$shortName == shortName))
}

#x is specified in char
#y is specified in lines 
draw.text.rect<-function(centerX,centerY,text,radius=0,fixwidth=0) {
  width<-nchar(text)
  if (fixwidth != 0) {
    w1=fixwidth+2*diagram.params$widthPad
  } else {
    w1<-(width+2*diagram.params$widthPad)
  }
  h1<-(1+2*diagram.params$heightPad)
  if (radius != 0) {
    grid.roundrect(x=unit(centerX,"char"), 
                   y=unit(centerY,"lines"),
                   width=unit(w1,"char"), 
                   height=unit(h1,"lines"),
                   r=unit(radius,"char"))
  } else {
    grid.rect(x=unit(centerX,"char"), 
              y=unit(centerY,"lines"),
              width=unit(w1,"char"), 
              height=unit(h1,"lines"))
  }
  grid.text(text, x=unit(centerX,"char"), y=unit(centerY,"lines"))
}

draw.right.arrow<-function(x,y){

  theViewPort<-viewport(x=unit(x,"char"),y=unit(y,"lines"),width=unit(diagram.params$arrowSize,"char"),height=unit(diagram.params$arrowSize,"lines"))
  pushViewport(theViewPort)

  grid.move.to(0.5,0.5)
  grid.line.to(0,1)
  grid.move.to(0.5,0.5)
  grid.line.to(0,0)

  popViewport()
}

draw.left.arrow<-function(x,y){
  theViewPort<-viewport(x=unit(x,"char"),y=unit(y,"lines"),width=unit(diagram.params$arrowSize,"char"),height=unit(diagram.params$arrowSize,"lines"))
  pushViewport(theViewPort)

  grid.move.to(0.5,0.5)
  grid.line.to(1,1)
  grid.move.to(0.5,0.5)
  grid.line.to(1,0)

  popViewport()
}

draw.text.line<-function(x1,y1,x2,y2,text){
  centerX=(x1+x2)/2 
  centerY=(y1+y2)/2 

  grid.move.to(unit(x1,"char"),unit(y1,"lines"))
  grid.line.to(unit(x2,"char"),unit(y2,"lines"))
  grid.text(text,unit(centerX,"char"), unit(centerY,"lines"))
}

diagram.draw.msc<-function(msc){
  actionsLen <- length(msc$actions)
  actorsLen <-length(msc$actors)

  titleLen<-diagram.params$titleLines

  headLen<-diagram.params$headLines
  totalLen<-actionsLen + titleLen + headLen
  totalHeight<-totalLen * (diagram.params$perActionHeight+diagram.params$heightPad)

  maxActionWidth<-max.actions.char.number(msc)

  maxActorWidth<-max.actors.char.number(msc) #not used now 

  totalWidth <- (actorsLen - 1)*(maxActionWidth + 2*diagram.params$actionsPad) 

  theViewPort<-viewport(width=unit(totalWidth,"char"),height=unit(totalHeight,"lines"))
  pushViewport(theViewPort)

  y=totalHeight 
  #draw the title of the diagram 
  grid.text(msc$title,x=unit(0.5,"npc"), y=unit(totalHeight,"lines"))

  xcenters = vector("integer",actorsLen)

  y = y - diagram.params$perActionHeight

  for (i in 1:actorsLen) {

    centerX=1+(i-1)*(maxActionWidth + 2*diagram.params$actionsPad)
    centerY=y
    xcenters[i] = centerX

    grid.move.to(unit(centerX,"char"),unit(centerY,"lines"))
    grid.line.to(unit(centerX,"char"),unit(1,"lines"))
    draw.text.rect(centerX,
                   centerY,
                   msc$actors[[i]]$longName)
  }

  for (i in 1:actionsLen){
    action <- msc$actions[[i]]

    y = y - (diagram.params$perActionHeight+diagram.params$heightPad)
    num = length(action$value)

    if (action$type == "message") {


      for (n in 1:num) {

        fromPos=get.actor.position(msc, action$from[n])
        toPos=get.actor.position(msc, action$to[n])

        xFrom = xcenters[fromPos]
        xTo = xcenters[toPos] 

        draw.text.line(xFrom,y,xTo,y,action$value[n])
        if (xTo > xFrom) {
          draw.right.arrow(xTo,y)
        } else {
          draw.left.arrow(xTo,y)
        }
      } #for 
    } 

    if (action$type == "actor.state") {
      for (n in 1:num) {
        pos=get.actor.position(msc, action$actorName[n])

        x = xcenters[pos]

        draw.text.rect(x,y,action$value[n],radius = diagram.params$rectRadius)
      }
    }

    if (action$type == "action.state") {
      for (n in 1:num) {
        fromPos=get.actor.position(msc, action$from[n])
        toPos=get.actor.position(msc, action$to[n])

        xFrom = xcenters[fromPos]
        xTo = xcenters[toPos] 

        xCenter = (xFrom + xTo)/2
        fixWidth=abs(xTo-xFrom)+1

        draw.text.rect(xCenter,y,action$value[n],radius = diagram.params$rectRadius,fixwidth = fixWidth)
      }
    }

  }

  popViewport()
}



actor<-function(msc, shortName, longName="") {
  if (nchar(longName) == 0){
    longName = shortName
  }
  msc$actors<-c(msc$actors, list(list(shortName=shortName, longName=longName)))
  msc
}

#from and to are vectors that may contain multiple values, 
#which mean that the events happen simultaneously
# value -- message
message<-function(msc,from,to,msg){
  theMsg<-list(type="message",from=from,to=to,value=msg)
  msc$actions<-c(msc$actions, list(theMsg))
  msc
}

# value -- state 
action.state<-function(msc,from,to,state){
  theState<-list(type="action.state",from=from,to=to,value=state)
  msc$actions<-c(msc$actions,list(theState))
  msc 
}

#actorName and actorState are vectors that may contain multiple values
# value -- state 
actor.state<-function(msc, actorName, state){
  theState<-list(type="actor.state",actorName=actorName,value=state)
  msc$actions<-c(msc$actions,list(theState))
  msc 
}

test.simple <- function() {
  grid.newpage()
  m<-diagram.msc(title = "SIP Call flow")
  m1<-actor(m,"alice","alice name")
  m2<-actor(m1,"bob","bob name")
  m3<-message(m2,"alice","bob","INVITE") 
  m3.5<-actor.state(m3,"alice","wait for 200 OK")
  m4<-message(m3.5,"bob","alice","200 OK")
  m4.5<-actor.state(m4,"bob","wait for ACK")
  m5<-message(m4.5,"alice","bob","ACK")
  m6<-action.state(m5,"alice","bob","in session")
  str(m6)
  diagram.draw.msc(m6)
}

test.parallel <- function() {
  grid.newpage()
  m<-diagram.msc(title = "SIP Call Trapezoid")
  m<-actor(m,"u1","User-1")
  m<-actor(m,"s1","Stack-1")
  m<-actor(m,"s2","Stack-2")
  m<-actor(m,"u2","User-2")

  #parallel messages
  m<-message(m,c("u1","u2"),c("s1","s2"),c("BIND","BIND")) 
  m<-message(m,c("s1","s2"),c("u1","u2"),c("BIND ACK","BIND ACK")) 
  m<-actor.state(m,c("u1","u2"),c("BOUND","BOUND"))
  m<-message(m,"u1","s1","initiate request")
  m<-message(m,"s1","s2","INVITE")
  m<-message(m,"s2","u2","initiate indication")
  m<-message(m,"u2","s2","initiate confirm")
  m<-message(m,"s2","s1","200 OK")
  m<-message(m,"s1","u1","initiate response")

  diagram.draw.msc(m)
}

test.simple()
test.parallel()