How to make a smooth revolution surface plot

Question

I'm trying to plot a 3d revolution plot from a set of 2d points. These data points form a 2d curve, then we rotate that curve around y axis and get a 3d surface. @J. M. has a well explained and very helpful post at here which deals exactly the problem I have. However, I tried to use the method, and get a 3d surface that is very rough and not smooth.

Here is the 2d data points:

points=Uncompress["1:eJx13Hc4lX/4OHAjW7JnhKRCpEIazrESokhCpUhZFR6KhLLik6w0NBSVShItoew9I7KyRcnWkozffY7v9/yuy/11/uJ6Xeec5zzPe9zv+z2kbF1Mj1cy0NG5L6Gjo9vl6O5xHP75//8RdP/zIthqIqQ/+0vkLfBLe+8n2IXeJBGHIt9WjWPnmTQW8VO6RSI2N3DYTGBXdrHfWfU5iURI5U2wswUgJ7HRV+oYvCIRno5F8Suwbz8vrxN8Hjz4Z/MhSezzn59JIra8NP+hir0mp0p1s0geiYjWrvMwwr41nt7/mjr4R/5HVsbYj8UYqbbYFZKIvQ+zPtthp/srzGocXkIiksU7dp7DXm417qP3CjyH0Nb3Xuz6y0kEs8qSs0L4/mU9C2Bjn6oiEZLfv5M9zyN/v1yw5qxqNYlQGLiXvR/7+URyyuG1tSSi0+RrY5Iv8u8lEaw2d+tIxOkpraiNPsj7ZBltr0+ANwfa5n4+t8j9qScR+/K2MYl4I+9K7mu/k9tAIvarV7UMeiGPKhcv4jH4RCJI1eSgA9gN/a1yTeMbSYTaFi39qDPIfY4VntjS0UQiakwvWu05jXxDDOtr/YfNJKKM59jbQI9F7n8Libj/8kbIMnfkcqumSvfNtJIIlvDKq0VuyEXVC3tGZz+TiFKrVOm7rsiFD3nU6Qq1k4i/B/+mm7sgl55d4dcu1kEiHJ+espI9hTylIOl3vmUniTBdbcbz6sQiz7eLRCRc+aUZ5Yy850lCrUgcuJTni2F/J+QrZHcyGVh1k4i2H5NzpQ7IieWlbstLwQ3KxqvK7ZG/Mt3Yo6PQA+VD++eF9uPIB5y2LnvF0ksi7PPiRtrsFik/4E+3nb7EiT1wuuiHyzvwSG41fvWjyD+Eu7LUvP9CIpwEXtowHUZuwd4wdY2hj0S8+ch8pPcQcmOJ+j4lErjuv9jOzIO4/A6d2l3i3U8ijoo1XPhtvkj5BA+0Pd1oij02bdO5zDxwsYIPfCn7kFtmj21dof6NRNDrfjrzwRi5xmRX4DINcEaTd1feYr9mFyhirAVuXafJ/gD7ilNL133wAd8JtznGCHnGRpn+Yc4BEjF6c9P9cQPkp+P7FHILwW8WTIpH6S1Sf8BTPiqWrcAuY/6+7v4f8LDpwIK4HciLyalHQnQGScTY5fK/pmT8fri6/86CNw4urdlDQr7tsWFHdzo4Q4n/+u0ayCcu2o5FFg+RiNy8q0Or1JELUevnMLSfW0P876ghv/Vlg4DeGXD7qwN89SrIL9+/P2e5Y4REDKzVJg0oI6cWvzfg0jma7g1KyCelRHc9UxklEdW2Jn8c1uH2J6eHS6YUnC9mPPqZ3CL1f4xECGtO23GuQZ6ceiE/1Bt8g3Jm66wM8t4TPMv+PADfPn3vi8tKfH2U4jcJPvoo0yFxBfLWgMa1OtbjJMKiL3V/lChys2ssAw1HwLOIs/Eu2D/SGfcPOoE7UcqRyCLtDzi9nJbINX7k9C52gh6iEySiXpOZuXYZ8pM9Ij0NeuCG9akKakuRD+2nPCFwn/dDvdmsuP3dma/N1wA+xB3jvJ4J+fFfb2+5Kv+A8m0f4N88J/5/t2/gNZcNjb5OIx/I+i2dFg5upMD5NHIKedvRFj4usZ8kgtOY77fXBPKOmqjYtxvBH7oZinGOI0/a+CxPXw983KBYb3gU+Zuxy4fVJsDD4GNk+pGPHBsY76f7RSLMd2il7upDPt++gg/KMp1VwT7Go2f3egl4Lv/sLD92/sHvDieywBWcE9TjW5F/1KXUUPC9BhZ6u1rw9fWfUyVGwGf0mPQSm5C7FPwInHL/TSLE1ZcITn5APt9+g3PJua1xrEZutTrl+vpm8EBdrp0qFcgnLg5+Clz3B+IH345wo2LkRe/jpJRdwP1W7Ji5mI+8xL7j90g+OLu2kH7xe+Q566W/jvSDV26y6IvJQj7fP0ySCH2xnV+yXiE3it0UmnIT/FNF7pKgZ8gbr4e2Zb0B1yg/GmL8FPl8//CXRLh/Lk93fYCfX7vYgeO7wH0+8Gx3u4vcy9c2UScZ/Km7cMPkdeTz/Qd43G3D/2RjkLdKMSqumAOXbjh62joKuZjdtlM18VMkQlCiWvJBIPKn1Bd4yYHqA20B+P4v3x3a/AK8baPDuCH2HUuKTzt1gtdQ2nE/5NRWi/cfifi8lUv3rTf25Lr6KDtw13aW/s0eyOf7N/Axsd2KVwj8/A0E1Syug/uX+Z80ckX+PNlmh6XQNPSPJMWRdceR35Wi3GHw3A8bL8fZIg9bw1leHwa+3/PJp9mDyC/5ZbNLVoCHhm1ZIW2BfL7/nCEReld8tThMcf2X0XULcgMfk2dymjFA3tAqsmbUh+JipT6i2FnISnqy/uDm/2WUFukjj6I2W+Aat0Y5vmgi/9LSUtCoNEsi3vkyiazYhuvHnlXasZ7gYxKdU1MqyOf7b/BLeZ6xXMrIL7Q+E9/SBb7riNG1bgXcvqrvyTLxnIP4X8/ZNVwcedAySg0GD7r6WENvOfKlcS3BGy+DN67UEnYRQ16RolGs9gach/ogkFf/snKSW05HJg6nRERwsyOfjx/Aq9svlVezINd3HT93Yju43pVCBnVGXP+jReT5CPCBp/ISlyaXo/hM2xa6KHAeneq90j+Qvy3MEl2fC36tTezal2/IrSaUOpeVgROnJBOEviL/S23+wN8frgjh7EAuLiRTYy5BTyY8f01Yj35C3nVAL6SWDC7Xk2b5qgZ5uh/lBoG79xSxRZQhb057oazgAX5m3Dp6XxHy605GFm8LwJXdqjK3vkbuTo1vwGe5yj4dfIU8hPWTHVsFuEPykZjCl8gP/2YzOtIMbkYZJqcil492NLsoyUAmdl+vN6lLQL4+69v9MEXw6yNpMar3kJdmbLFr1gbPzqPr/O8Wct4bjMYlZ8C9Zw1F70chH6bGV+BTS6PEYv5DzslrTb+qHFyVaY545oP8yH4md/YKcHYpBS5P7E9/UdoV8IupJsu43ZBb3H/hc1KckUzsqEnvd3JArnieT2O1KXitirO9yAHk9tT4DbyFXlom0xz5huO8B5VdwW1//rqauxe5Y2V2nPId8BvUhhj//uVMTNkF4H6cpZxtGshlqB0keDlfNuP5bcjvns0UX94GLt7SnxGzGX++3AbPboElZKLA56NRtBzybmr8CC42FM61byXy8yxb3MOPgf/9FnI1WhD5nXumzlcdwK+a1XF/EsDXd+Jluext8EKGFf6/2ZDHHo9X83gH3uA7k6xLj1wks0+EexR8+acZCb+fYgv9ALV4MZGJiMK1XdxjyEVv6bw/xQV+k+/CXO0Q8s+7r8Z93Q7eSmlHupAbxL58rm0DzulRlafajFz4CaUAgr9Y1+Df/gn5BYHNiiVe4IRg9Va1j8gtKkIqe16BH2K98Ox4IfJP1PiXiVL/zAP8spB7u61ocZwBn35NaamQ66Vb/z3IyEwmIs1VktySkTdyMZhHsoK3Zsnotichv9K7OaJ3M3iSuGmP5W3kOk7Vl96ZgteeCGCziUFuaj5dsToOXJRnF/1rH+S7qfE3eP5/mZ2l5/DvV5OXZrkP/uBOjst27BdH3+k8fwwuTg2kkCtbJRtfGQfXlBJ3tjyKnHOFz1g+CwuZ2Le8mT/tIPIVAnvotiuDs42JzCzdgzyPLN39lwzO70RUmRgiL6fG/+BOw6I8TtuRD93zKPOJAg+QfxBwbCPycIbIUqVicMv46eOXVuLfT02Pgts9jpUylEAuNFeSOtcJPj5Uv/msGHK+6mFD2TnwI9RAFrnd2j2D+9lZyYRNUFPSOy7kWtYiNwKUwA8/XzJ6mRG5NnV8Am5tI7hBYU50oU+NVkdIW4In7emsZf6D/FS2sx/TefAaF5XE+EHkdNchKk8ED/WxYDjVgTzoM7HmbRX4mjFRid465L+sZMgKP8GdA5/uOVGIPJs6/mGD57t1v7BlFvLrvW3n7IXBfayOkmXSkUfsFxd+owb+gDoQQf54cMcHITvw2qJk22O3kHvXURoA8JSLpRGuV5Fb/RR38rwBXhDycX9UCPKMH2nSZangMko/gx75IVejjr/Av0pe/Bp4Cnn5P9EzXv/AvW5ue/zVFnlhuNDVgi3sZELo8pT1a0PkP6FSbtUGr4sR331zJ/JO1RSvdXoUp/6BfEJtYlunCXg/9YOQf4RC++MM+A6jAYaHKsi/c4wub7kCLnmqetBRHvkL6mMBz2J+k/5cGrn8ap6cpR3gJ6OkjzcvQz5+Vkv+EsUdNebKkrGfolYrDjLx46EJj+aMyELfY7OeNVYOnCO00sPgJ3IW402pwSfB11IfFPKV68weHDoDLpVe3RHfjFye2iyC09/pIpOakIsbPXlR7Q+uxpryIKQe+VdHwup6DvjqfRV2TpnIv1G7TXDrwQdslU+R79fPPnGNmZNMfL7+Q3fqJvJ8ztyIms3ge/rf/vkViDyRGjaB893+1UP2xe9/y+ISbQwear9cKMQbuYRq+LD/QfAT1IqE/N2ES17ydfDiJUfVNhxAbksNq8EzVq86ZLwH+cC+vckvOsDVKmTGy7Yiv7ZNq6trFFzdzLzJdBPyFdRh21Jon2ydbnitxO/feEqwXhZ8FbuE/LnlyEdHeSpuG4CnUhsq5FktRzVHT4GH807IrJkRXuht1LQG+P1Vaf+MfyMPXP+wLPUROMusgOSPL8jvi53g5HoLnpHenNPUjvwmdXwOvnrvseFj5cjDDnk0KcyB91rlWoTkIHcPMtp7dSMXmZigXGci8ksa9f+mdMBl704b9t9Bbk6d9gD3dW2tMo1FHvTK6GyOI3iRcET83v+QP5i4ctk7FDzw9a3k317I+aj5AfAmgfpdmjbIsx+Zik9VgndWbOZg2Ye842vfFfE/4CrUjhJ5kxXv87PLlpGJbd2NTkLKyGvdKANIcOV3lVVKcshnlG9rTOwAZ91syxnJh/zLy+YE1r3gl2+fW6e2FHk4NT8B7u3Qu+baD6GFvmRq+9Gy6+CjOrnZIQPIPXo5lu/LAveiBirIj6qz99m2gkf3O3K9KkZukHIYIhBwF/5DEY3vkddLrh0c4uImEyImUTVZCcgZRoTkvXjAc+VHV9HdQx5IzX+AiwcZ+fNeRG6Zy/voy3pwhzFNvq1+yFs1Vb2aNMDfUQM95Nyj0XlbTMEFX0oIeVkit6VU/0Pgk3PDF2IM8fVbxyq9cgPXmGAr+rseOZfZuzfqkeC2M+WaQ+zIydT8C/jWLTc1elnx9RcTLbLR4Btk4vrdsB+IveaSSvFZCUqgjDzYttUjJQ28KtdgaFmXIGp/oXe+WAQu6lct+LAEeclgFZtcLXj0Jq6+m2+Rd09Oae7uAdekDhSQh+pfGkseBbcwtfdXjEQ+Q80Pga9Z+rxQKQi5wWO9pnXLeMiEhGueeOFx5OYOahzeK8AjiR+lrSbI21L5YQQIHuBoe7BZEzknE1NOqiL4l3CRrP0ayD94JfGObQAPog60kNfYFjxUNgZPTibMhwSQZ1HzU+D8jxSXNU0JLHSndLqmMWfwNW+q//s3gJw9xrZP6hx4KXWgiVzIsDMgIhS8mOyYVvoOeSwlPRID/iBmdPfOp8hLiuPH194G/wbF4H0c8uLObEWFRHDbqiVNMeHIWd9QfiB49GUJ2dALyP0nO2aU34GzUwfiyAmPO63l+eBz++NnDh9G7knNv4H7BxtNl5oj3y4vzr7lM7gCpR9RRf7qgNR1+w7wktBQbQVl5Cl1Lhwsf8Hvbn84qcSM3HyQkiADP+yZ/ESPEXlVnOUGpn/g6i5NBpMMyCcPHRDUorgRNRGC3MAinP+BEC+0vzvEO4oa+Bf6Jmr+D9yGWfi/ilTkZ5pZu3U2gfMlTejefIS88ar06j1bwaOoiR7kIXRWuxN2g3sfcB/vOY2clxLV24LvCovb8dAYeaHmMYteB/BNZIePf8jI675YbzF0Aa+nJrKQ99s83i8ZAJ7dU3GPgRP5ODU/Ce63vzxatocP9e9qavusboNbjZY5sjQhv7Jh7dGweHBBaqIO+UY9xq3Rr8E73EhLmO8jr5W9DTcOnHXj1M2Tp5Hzs0tOFFWDd1nu15w9gVz58fLYV3XgltREJfKmm6SmmX7w5M8erXSbkT+n5k/B975WGwtjQ97Ts6/Sjo6PTDDVno8+zIjvT6/4PR5G8DvzH7TQV30O9y0SAH8u58D/pgr5x2r3+3xC4GtYb3EZlyM/3mRzpG8NeOf8g1roOvKz6ooK4Marwjn5LyO/TJ2ABaefiSJW+yJ3fKqULqoJ/jm4pt7XGDkL/zlF9l3g0vMVZaGTCs7l85qDVwjpZs5yI3eefyxkwvzIlvclfTwLXcXzyGo+Z/DJ3qG9UfXIvRoT5sxcwI/NN1QLXU5BN5zvArhs2tURqevI100X7pgLBu8yaN1TG4ScWYosU3oF/Ml8R7LQo+lzBYaugqtlH685aoHcgBJexIIzPvuu5LwT+cs1HO4/EsHfn2zfz8iHvIu/cX9bMvjgfEe90PcRZh7hb8B1jxqvLatAbu2RzL4pC7zg/cCNP6+RnyvPUSzNB1ecD4QWep9+g0p3EeX3eyicowtAvma+WsP9T5MKS7JGLqwSd1i2Adw05U6cmDryzUrickQTuNt8oInGd6mtn/w6wW88caydYEBuKHn8P+de8D+VIhdOdi1b6L+vnlslPgzuOB+oo/hJujmwfRy88dZdlv2GyMMU9EY7J8HbpTqaA+q4UPluzfBRmgIfq6cOdBZ6wibnuiGKWz16/PlNPHJmOsqLH8an5SZx56SQb+rXD+ZiAFdS7txpPbJ0oe/J3HXrCMXPzA8kFzpj7F+6OooHbK5T6mpFLq8gJcPKBh659K/N8a3If/6ouuHKDj59kDoQX+gTxzKVrDnBdxdH8Fb3cS50aWKygJ4bfGyA99ypUOSxikbXLvCCB84nMha6W5ZGMr8AeLOaagH/T46FntoXEWxH8SSftSvFPiBXfpJWUs8Hzj6f6FnoCvmTAX084O7d7PQ/lJFf+KE/vo5y/ae9PrrYDrIv9BjpgLP+XOBR84myhX7RtWr/qqUU/+ZlKHAGuY310Lgb5f4GfBPmvsqEXN+AITOO8nwE5xORC91B2SI5gBU8Ion5dn4m8ktSKXTdS8BTMpu/uUki76Jr4wiheNx8InfR8jl4Ytr/bhXrQl8peJcpj1I/Uu85nFx2AHldtxjd2t/gMvOJblQ+Ha7NpI2Bi8SqetfTIX/Vvom8cpDS/utWSD4sYEHx7bEdFqmU+v90fiJhoWslVnpfbAfXHJJv2CyHvDElK3WiHvy7e2jXvxzmhb5+wDVNpQ58/fxEDOqfT9i+GfgAfulKeEh1NHJa+9jMwWIj6oq8TU0v2TEP/JvcW6NROuRaLTFbtN+Bv52f6FromeWUAAl81lBxO0cMcovPl+TePgf3tTk20uqFXMCbzbUyAdzZ8cL5C6uRb/IyYP9wG1xjfiJxoe98stYh9Ba4zsSja2+nliza/11oJtddG0H+5WlQgtJFcItnf4y2+SJPO37bfdQLvGh+IhbFb2wnBf1dwfl+8QoLMyGnxRcrEzXYZMoYF3pZXqy4kBV4U7vkze5I5Cos2YFtJuAG8xPd6P57FsmkaIPfKlEUTRZFTouvHmxu+1pWzIDKX9FL1q/y4EnmG9b0PUU+EGj8clQWvG5+oQDq33pvTi/hpcSPd01/R2gjp8WvTn6HT0VN0y/0wUp6Dt3f4EcLXazSepG3fWVqFR8Bt5hfiLHQP/sn20e3giukBQfHByKnxe9uNZaiAzuR78pd8e1nDviQn5vUppXIt2Q90cx4SRkfzC9kQe2nm+6I4wNwiXM3HvkXIKeNX9zH7dk2X0PuKRpPPAihjK9uD2zItkVef5HLTNsD3G5+IdBCNzNX8aynjL8OuprkSCxDThu/yZwseX9sei53gfso7zJlMgAXjhDkqY1C/k5n5ZE/euARv5+52oQgp41P97KO7nrGi1x6I4++2GrwY5xv7YLHZhe6q8Vgr4woeCM1fkGe/txpSScz+McMu+KnZshp4/PElFW8vJLIZVe2abcPgx+cX4i20IdM1KeG+sAV1zia+uUgb0vujWSvBmdrtihI34Gclp9Y43dByHcN8t836yOzisFHXLm7zaSR37oSPaFRCN5LjW+Qmx/zOhlLyb/8uXtUKSl4eqHT8jsN21sf7tuDfI9RyMqMAPAN345ljcz+W+hJTlHFHUfBnXV1NwncRk7LX+kyJJh+jECuH6Mt+uEQuJfmDMk7FHnBowaGzxbgY33UhZTo+89LVJpvpuTX7O/9PC+InJa/q/bnONk3PLXQn5cHrffkBz8zv5B0oe//UuL/mhdcqvKT96dE5GknluWXcYNfqypskIpHTstPSgeGXfxqiZzpgUptwhB4tnWL1vPNyE1yVlsrVIHPnKIupF3ow2az+pdKwC9aLE1LqUROy89GiM1J5ZYgz/O0WqGTB851535YZibyT8ylhUQ8uKmppniKNXJa/vnFmo6dyhrIX/x99qXiLHiITpiJ0u/Jha7J6vx5lpL/ZrmRsn5XH3Ja/rxaRV19Lgf5W7Imk7AJuPU121C2u8gHuV+r8cuD79jr0/TKEDltfkD7rtHHLTuR54R8WnVsDbhKv3pury5yw9EjI1dWgrPPL9Re6P6tAzay/5ZB/6KdkZA++2eh0+Y/1h6OfE76iXyIw9de5RP4FcLc52Ef8oba5zo298HHJsRNuYqQ0+Z3JoUncvtTkV8we2VrbAneyJG+rjgGuYb8AabP+uC7efsvOYUip81PVWWQ4znskVdciXdaNcEF8eeMvnKQPnLNru16w5/Bq14cD5rZipw2/8bg+6S4VBw543S58dWb4Pu7xds4uJDb6n5rLTsKvjP7+o01f3+j9vF/5w+DB9OkQ8eQO1829NyxFbx4TfTpiwPIJ4a385HGl5KJs43u23OqkNPmR12yU0uPlSF/tzz2y1wbeIRr87/eIuTqKc0Cc5T5W6H5jQwLfTWHScw7ig+TTvlsxk6b/2Xpuzeigj3J7j1LCsV3rflZvwH7lb9sWp6S4IbLlsxcPoecNr99WzJRxMMb+Uxjl0nhUvBoB878ndjNJUZ6MzI5oX4yDaeVeyGnzc+T++s9pM8iv5TQc0DyEXgm262Us9iLHzs5HjYBv+Hg0Uj4IKetP8js07YtxN75YpvNDRL4bH5oCK8vcrq7gjs3fucgE2+ENW4cx/eHtn6irqnebDP2uF3JZzKawIcelCfsxT6n5Tt6Mhi8dKm4Sq4rctr6j9zkMtM9bsir3Y++Uj0FnvB2vSWbO/LnZYaDw6LgQhcO+jPg30db37Jra8zpKj/8/qIbazXYwQWI0N+9F5DfOy4gZ/OMnUwciU7N97qJnLY+Z2xH8GwbdpvlTWYySeCNepwO6reQexnZnLGJZF+0fvAlFsecoKw/uta9a43QC+S09UsKTU0qPC+RX5NNW+qhAX5FNOeU6yvktxhOb3jXx0YmHtZE2XPh+k1bf3VBZcfo6Qrk7wVmc+/UgjN8nevirkZel/yenu4iuMd3FceOfuS09WO90vlvO4eQL1GaNaU/DD7CfrY2/xfyR+9Cy3bIgWfGD+1MF0DtJ2193OthQ4Pzq5FHPdvDJNrHSibK455o3Sch9/NQueheC77s36olsruQ09b36c7uC1l6GHnvN4d4Dg/wa9reytpeyOmF8zR+ngIXOGsX6+ONnLY+8UwwT0ZzJHIfl5GHlYLgIw2CrHQJyDdp/Q1qnGIhEyaWf7NUU5DT1mfamJ+OYM1GLvjbPSksE3zn8Vcd78uRO57YUJlxEfyyekT7WCdy2vrSsEPc9FzjyAMGDo6xHQYffdqeQ8zg/jM9ia+Psv517Lbcn4DtKD6hrY/ldLY2uoNddYPMdBLFX+r4v0zF/mjPegd5ii8S/+zx0PdKS2MmE0uL7thfPI+ctj54ewYxORCGnJHdQtAkFHzrp++rBXF855R+6me6JbijdsbyQ/nIaeubO+jPH1FtRf7zELNINmV9dDBXskXSLHKu8aLulwzgww9vXGdjxPHx/67fPvClv65iFfIguUs6z5LBs+g39ifrIPfjUPV9cAn8aPcxxr2WyGnrz1vYPmvtc0Fuwd9Tv8YMfHaFyDerIOSzwgk3WDnB3TZt/ESfjpy2vp7HbN+5kffIPfoGRPdOLyETtp9zyvIKkN93Sv51qWvJouOTM6znM/Qegx/ouMm4hxONb2j7B3gicoazBJHbm8aL+YeCNzel0h2VRd5uruSqbwI+HNH9iM8UOW3/w3LtoN+sJ5BLiYa3BDGBT2me0blxFbnZy4KaA9OMMD5zf9Mncgc5bf8Gc9TLhL25yDmvN7V8fwQedTaykfcL8gEPkyL7APDvhzsajBnR+JW2P6V25135AVHkB5YwcEmZgOcm5To/kUPuGsmo1z/LAOXHL5Ip1h05bX9NoqwvedYDufofJyPfafB1QwPrGk8jbzTW0XaZZFh0fC70K0rO/TFl/5EVq71TLnLa/qHXzfSWElXI07OtvbV9wauM77gfb0M+zZQk074HXEpglO8DA8pf0PY/hWzRS26WQh6c0bDn7jQ9jO/MZf6L2o2cdTnH9lWT4FHWdg+l9yKn7e/6w9Elb+6FnF+Pzzj4Mbg9S6LWQCzys9x3OqrcwRsFblmWliCn7U97sN5lruET8jM9lWciTMF7Bpc+rehBbvzlwCCrCP2i+aEzK5/fk52lg+8/Ls77TRE5bf/d1CrzYpFNyF+b1VrTj4L/Cte6unkb8lauVzZWSeCHwt52uJ9FTts/6Pp8OoslEjnH+EsXFyfwR4nKlwvTkKt63eg8ZAae9fjDLY1C5FcOa994u45u0fwdbX9kv+qDtF8DyHdWnq0MnJsjEc4Ng55hXCg/uF3u9urMavCjd8lqplLIafs/r253M2vZitwn5cnB86bgpctqrUmmyEvCtAY31cySiEN2zoNxAchp+1f/ef17syMc+4GWuDsPwRu73yaqXkVOTf8ZgTObnd7b9QJ5WDqvb7Mu5f3/d36VYfvB5wZ/ZkhE1nKdsN1NyGn7d5251BmOtSPXa0p0j60GdzCXEBTtR+7yd2rDGwPwi5yslt1iKD9M25/8qV328LKNyLdcHOsaLJ8mERH+DJ7pu5Hbb9unFHsX3IlNW9DOBjltf7WHS8VQRBDy0tqhtaUT/0jE8qTJD36Pkf83fdCdtQR8VvxBeF4mctr+8F9klx1bW5BnphikmeqBT7RsSTAdQf5m6anIq3lTJMJSy7fsNB/K39P2xz/NuPWGWxg50/0puUN3wHPvRK3jFUP+0uQ4g7EF+CLzB31PhI3Mxv+SCOHO8RdfNZDT9v///U8mLl0Tufev7/uG3oOLrci+R9qJXMgkUKRNG7yw4F6X0RHktPML+h+zvLntgFzqm25GeO4k1I8xic+5Z5BfdbU29o0BzxLP8az2Q047f0Hul5J682Xk6veC7kysApeab8gW+oYu7q8fu/+QiI9lrwj6O8gTkyMZmUvBZ8aj1znGI6edL/HAkVWs6jly1+BzV6aVwC8l2Vxgy0T++M3mA4MffpOIgGeJ7ollyGnnY6hkh4YeqUVutVvlNZsf+PBz6yW/PiGX2xB+fKT5F9TPn0uZi8aQ0873OClxK5N1AvlaYxEDsSpwlYHg6S/Yw6ws7Xqegi8yf+Zu8VJKVBT8r6KtasEyNP9GO79EwC6Z9Sof8k1bpMYnun+SCIYXqiLdwsglVoTcCXAAl1D25mNbh5x2Pstk0m7dKhXk/RaD9x9//0EimszXMhlrIh+TftRcnQ7u6Nr2YoMBctr5MlbM5OTL5sjXKF1O4GUGF8tgat/ngPyWfFP2oYkJEpG0cyok0wk57XyckODIPqPTyKeYquq8jcGPV4S63DmPvJfYKjTKBP612LRKPxQ57Xyf693bymcjkT/bLXd9yXXwK9Q/kJMj5R1WioJzn1ohopaInHZ+UfQhrbuHk5Ar9BWK5beDX5Zk8bv3DHlcsljmfkXwLYJDx2QKkNPOXwptfS+Vjz3F+1CC7yrwi+O9x7YUIt+Z4JbTyAS+yPyzleSIkUfrCIm4UJBn9KkFOe18KbMwXlXNNuQ/IoX4hYPBj+ZkvOTpxPfvt+ngQedhEjHkkD67ehw57XysIykGs8Rv5IEhWn7Xng6RCGmWI7c9ZnD54F3K/mh6kEQUvDQfe8qK5u9p53ud2KUgq8mNPCNfi7jz4TuJCH++PJd3OXKdnEvL1kaAdxdafDKQRE47n4x1ON2rcjVyL3tbFeOt4PzzA4GFHvT06TYPbnDvX/I1xuuRKwkMfShmBbcoX/L8Hnba+W0/M5Qnf23G7zfND1575SuJKA+aamAhI58qWjv1Qxf875v7qnJ4/QPt/DnfKDu+KX3kn/821XTwgYvwl3/O24281MNeRjqwj0TcvE/Ofb0POe38vPKNJ9O6rJD3/4rr0b32hUTEGo2Wmh5GLnaYaOnJ6yURv8c9GX7bI6ed/xc2ZbryuTNyT5bKXTGC4K08+p1Np5Dv1pDdUDzbTSJ6S1rdZb2R084v7GV+9NrWB/nYrpyHJTfAuceCh3f7IQ8Qb730eFsXiai9vb3P/DJy2vmLg5LpVhLhyJ2uvJj+KwyuV1PwrxQ7B7X+dpCIwO8RDt54/cs+K0J1JhJ8kfUx4SK6XD/WtpOIkYsaKx/dQk47f/Jt6phqC/bvwvGZwwzgbQ5zLdy3kd9vCjljy90K/bvblcOSDxapXy0k4lVVi1Ia9miNhG1B98H/9v5r3PUQuWL5C3/9X40komJtfNDm5EXKN7jrWLEy/zN8fdemtrzXBn9nKn1aMgV5XmcTvWJTPYn49n2IOerlIuUP/P6r7TW+r5BfiFZ0aRv4SCIMhD8yZb1G7rez3Vokoxb6lwtu5KTMRcoH+Lki5w3fs/D6p/wTzf6SH6B9+LYrSOs9cpO5SztOKFfC+KW8pv553iL3v5xEGIaHjygWIK874vPR4GQZiYjLLGWoLET+8OSBD4kTRdA+8CnYvy5d5P4UQvvYxXBiuAzX/8GWe5r5+SQiv6q55GQFcv3L6i22e7IhPj0rtF2nepHrz4TxK/PE4zPYtTxzbvQcSScRe77yuyRhn7MnJ2o4pJGIZmmxg/GLfX4SiTg1Jcp3G3vJhU6mHa33SYTODQlmlhrk2rkfi9mvhsH3z1wbkMbvp/ufF1H+sPq1Mvj/A+ndrWo="];

and this is how it looks like

Graphics[Line[points], Frame -> True]

and then I use J. M.'s method(code copied and modified from here) (it will take about 10 seconds to run)

parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]

tvals = parametrizeCurve[points];

m = 3;
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];

circPoints = {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1,0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};

wgpts = Map[Function[pt, Append[#1 pt, #2]], circPoints] & @@@ ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

and then generate the 3d surface

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

We can see that the surface is not smooth. It looks like the surface is composed by flat rings. So how can we make the surface smooth?

Edit:

I think this unsmoothness may come from my data rather than the rotation process, so I tried to smooth my data using something like

pointsSmooth=ExponentialMovingAverage[points, 1/20];

then I get the a smoother surface, but ExponentialMovingAverage seems to have removed the end points and there is a hole on the surface, which I don't want.

Also smoothing using a smooth constant like 1/20 largely modified the original data:

Graphics[{Red, Line[ExponentialMovingAverage[points, 1/20]], Blue, 
  Line[points]}, Frame -> True, AspectRatio -> 1]

So is it possible to smooth the data while keep the general shape so that it will give a better smooth surface? Or there are other ways to contract a smooth surface from the data?

Answer 1

Sounds like what you actually need after your edit is a way to smooth a list of data while keeping the endpoints fixed. Here's a dumb approach that will work with any "symmetrical" smoothing filter, including GaussianFilter, MeanFilter, even MedianFilter. It won't work with ExponentialMovingAverage, though, because that's not symmetrical, although it should if you average the results from ExponentialMovingAverage and Reverse@ExponentialMovingAverage@Reverse.

smooth[list_, filter_] := 
 Take[filter[Join[
    (2 First@list - #) & /@ Reverse@Rest@list, 
    list,
    (2 Last@list - #) & /@ Reverse@Most@list]],
  {Length@list, 2 Length@list - 1}]

All it does is it extends the data in a "flipped" form about both endpoints -- for example, $[1,2,10]$ will become $[\color{grey}{-8,0},1,2,10,\color{grey}{18,19}]$ -- then smooths that, and drops the extra entries.

For example:

smooth[{a, b, c, d, e}, GaussianFilter[#, 1] &] // Simplify

{a, 
 (b BesselI[0, 1/4] + (a + c) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (c BesselI[0, 1/4] + (b + d) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (d BesselI[0, 1/4] + (c + e) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 e}

:)

---

Turns out GaussianSmooth smooths across all dimensions of the array by default, so the $x$-coordinate gets averaged with the $y$-coordinate and vice versa. Oops.

{xs, ys} = smooth[#, GaussianFilter[#, 5] &] & /@ Transpose[points];
{fx, fy} = Interpolation /@ {xs, ys};
RevolutionPlot3D[{fx[i], fy[i]}, {i, 1, Length[points]}]

You can set smoothedPoints = Transpose@{xs, ys} if you want to use the whole parametrizeCurve stuff instead.

Answer 2

The the roughness on the surface is due to the noise in the original data, so that the first derivative is not smooth.

This shows the first derivative of the x and y components using original data, we can see it's very noisy

tvals = parametrizeCurve[points];  
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];  


df1[u_] = 
  Evaluate@D[
    BSplineFunction[ctrlpts, SplineDegree -> 3, SplineKnots -> knots][
     u], u]; 
Plot[{Evaluate[df1[u]], Evaluate[df1[u]][[2]]}, {u, 0, 1}]

We need to remove that noise in order to get a smooth surface. This can be achieved using linear fit. Andy Ross presented very effective a spline model fit at here. I modified his code and create this function to apply to my 2d data.

dataSmoothSplineMethod[ls_?(ArrayQ[#, 1] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], knots, data},
  data = Transpose[{Range[1, lth], ls}];
  SplineModel[data_, deg_, knots_] := 
   Block[{basis, allKnots, n, kmin, kmax}, n = Length[knots] + 2;
    kmin = 0;
    kmax = Ceiling[Max[data[[All, 1]]]] + 1;
    basis = 
     Array[\[FormalX]^# &, deg + 1, 0]~Join~
      Table[BSplineBasis[{deg, knots}, i, \[FormalX]], {i, 0, 
        Length[knots] - deg - 2}];
    LinearModelFit[data, basis, \[FormalX]]];
  knots = {1}~Join~Range[2, lth - 1, Round[lth/(knotNum - 2)]]~
    Join~{lth};
  SplineModel[data, 3, knots]
  ]

dataSmoothSplineMethod[ls_?(ArrayQ[#, 2] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], lsx, lsy},
  lsx = ls[[All, 1]];
  lsy = ls[[All, 2]];
  {dataSmoothSplineMethod[lsx, knotNum], 
   dataSmoothSplineMethod[lsy, knotNum]}
  ]


f2 = dataSmoothSplineMethod[points, 20];

and here shows the comparison of the smoothed data and original data, we can the changes are almost not visible

Legended[Show[
  ParametricPlot[Through@f2[x], {x, 1, Length[points]}, 
   PlotPoints -> 100, PlotStyle -> Red], 
  Graphics[{Blue, Line[points]}]], 
 Placed[LineLegend[{Red, Blue}, {"spline fit", "original data"}], 
  ImageScaled@{0.5, 0.5}]]

but the first derivative is much more smooth

df2[u_] = {D[f2[[1]][u], u], D[f2[[2]][u], u]};

Plot[Evaluate[df2[u]], {u, 1, Length[points]}]

Using this smoothed data, we can create a much more smooth 3d surface

pointsSmoothed = Table[Through@f2[x], {x, 1, Length[points]}];
parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]
tvals = parametrizeCurve[pointsSmoothed];
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[pointsSmoothed]}, {j, Length[pointsSmoothed]}];
ctrlpts = LinearSolve[bas, pointsSmoothed];
circpointsSmoothed = {{1, 0}, {1, 1}, {-1, 1}, {-1, 
    0}, {-1, -1}, {1, -1}, {1, 0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};
wgpts = Map[Function[pt, Append[#1 pt, #2]], circpointsSmoothed] & @@@
    ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

Answer 3

You have a lot of points, so generating two interpolation functions from them, one for the bottom of the surface and the other for the top, should give a smooth surface of revolution. If the default plot isn't smooth enough, you can always increase PlotPoints.

max = Max[First /@ points];
ii = Position[points, {max, _}][[1, 1]];
btm = Interpolation[points[[;; ii]]];
top = Interpolation[points[[ii ;;]]];
RevolutionPlot3D[{{t, btm[t]}, {t, top[t]}}, {t, 0., max}]